dbcsr_min_heap.F Source File


Source Code

# 1 "/__w/dbcsr/dbcsr/src/utils/dbcsr_min_heap.F" 1
!--------------------------------------------------------------------------------------------------!
! Copyright (C) by the DBCSR developers group - All rights reserved                                !
! This file is part of the DBCSR library.                                                          !
!                                                                                                  !
! For information on the license, see the LICENSE file.                                            !
! For further information please visit https://dbcsr.cp2k.org                                      !
! SPDX-License-Identifier: GPL-2.0+                                                                !
!--------------------------------------------------------------------------------------------------!

MODULE dbcsr_min_heap
   USE dbcsr_kinds, ONLY: int_4
#include "base/dbcsr_base_uses.f90"

   IMPLICIT NONE
   PRIVATE

   PUBLIC :: dbcsr_heap_type, keyt, valt
   PUBLIC :: dbcsr_heap_pop, dbcsr_heap_reset_node, dbcsr_heap_fill
   PUBLIC :: dbcsr_heap_new, dbcsr_heap_release
   PUBLIC :: dbcsr_heap_get_first, dbcsr_heap_reset_first

   ! Sets the types
   INTEGER, PARAMETER         :: keyt = int_4
   INTEGER, PARAMETER         :: valt = int_4

   TYPE dbcsr_heap_node
      INTEGER(KIND=keyt) :: key = -1_keyt
      INTEGER(KIND=valt) :: value = -1_valt
   END TYPE dbcsr_heap_node

   TYPE dbcsr_heap_node_e
      TYPE(dbcsr_heap_node) :: node = dbcsr_heap_node()
   END TYPE dbcsr_heap_node_e

   TYPE dbcsr_heap_type
      INTEGER :: n = -1
      INTEGER, DIMENSION(:), POINTER           :: index => NULL()
      TYPE(dbcsr_heap_node_e), DIMENSION(:), POINTER :: nodes => NULL()
   END TYPE dbcsr_heap_type

CONTAINS

   ! Lookup functions

   ELEMENTAL FUNCTION get_parent(n) RESULT(parent)
      INTEGER, INTENT(IN)                                :: n
      INTEGER                                            :: parent

      parent = INT(n/2)
   END FUNCTION get_parent

   ELEMENTAL FUNCTION get_left_child(n) RESULT(child)
      INTEGER, INTENT(IN)                                :: n
      INTEGER                                            :: child

      child = 2*n
   END FUNCTION get_left_child

   ELEMENTAL FUNCTION get_value(heap, n) RESULT(value)
      TYPE(dbcsr_heap_type), INTENT(IN)                  :: heap
      INTEGER, INTENT(IN)                                :: n
      INTEGER(KIND=valt)                                 :: value

      value = heap%nodes(n)%node%value
   END FUNCTION get_value

   ! Initialization functions

   SUBROUTINE dbcsr_heap_new(heap, n)
      TYPE(dbcsr_heap_type), INTENT(OUT)                 :: heap
      INTEGER, INTENT(IN)                                :: n

      heap%n = n
      ALLOCATE (heap%index(n))
      ALLOCATE (heap%nodes(n))
   END SUBROUTINE dbcsr_heap_new

   SUBROUTINE dbcsr_heap_release(heap)
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap

      DEALLOCATE (heap%index)
      DEALLOCATE (heap%nodes)
      heap%n = 0
   END SUBROUTINE dbcsr_heap_release

   SUBROUTINE dbcsr_heap_fill(heap, values)
      !! Fill heap with given values
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER(KIND=valt), DIMENSION(:), INTENT(IN)       :: values

      INTEGER                                            :: first, i, n

      n = SIZE(values)
      DBCSR_ASSERT(heap%n >= n)

      DO i = 1, n
         heap%index(i) = i
         heap%nodes(i)%node%key = i
         heap%nodes(i)%node%value = values(i)
      END DO
      ! Sort from the last full subtree
      first = get_parent(n)
      DO i = first, 1, -1
         CALL bubble_down(heap, i)
      END DO

   END SUBROUTINE dbcsr_heap_fill

   SUBROUTINE dbcsr_heap_get_first(heap, key, value, found)
      !! Returns the first heap element without removing it.
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER(KIND=keyt), INTENT(OUT)                    :: key
      INTEGER(KIND=valt), INTENT(OUT)                    :: value
      LOGICAL, INTENT(OUT)                               :: found

      IF (heap%n .LT. 1) THEN
         found = .FALSE.
      ELSE
         found = .TRUE.
         key = heap%nodes(1)%node%key
         value = heap%nodes(1)%node%value
      END IF
   END SUBROUTINE dbcsr_heap_get_first

   SUBROUTINE dbcsr_heap_pop(heap, key, value, found)
      !! Returns and removes the first heap element and rebalances
      !! the heap.

      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER(KIND=keyt), INTENT(OUT)                    :: key
      INTEGER(KIND=valt), INTENT(OUT)                    :: value
      LOGICAL, INTENT(OUT)                               :: found

!

      CALL dbcsr_heap_get_first(heap, key, value, found)
      IF (found) THEN
         IF (heap%n .GT. 1) THEN
            CALL dbcsr_heap_copy_node(heap, 1, heap%n)
            heap%n = heap%n - 1
            CALL bubble_down(heap, 1)
         ELSE
            heap%n = heap%n - 1
         END IF
      END IF
   END SUBROUTINE dbcsr_heap_pop

   SUBROUTINE dbcsr_heap_reset_node(heap, key, value)
      !! Changes the value of the heap element with given key and
      !! rebalances the heap.

      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER(KIND=keyt), INTENT(IN)                     :: key
      INTEGER(KIND=valt), INTENT(IN)                     :: value

      INTEGER                                            :: n, new_pos

      DBCSR_ASSERT(heap%n > 0)

      n = heap%index(key)
      DBCSR_ASSERT(heap%nodes(n)%node%key == key)
      heap%nodes(n)%node%value = value
      CALL bubble_up(heap, n, new_pos)
      CALL bubble_down(heap, new_pos)
   END SUBROUTINE dbcsr_heap_reset_node

   SUBROUTINE dbcsr_heap_reset_first(heap, value)
      !! Changes the value of the minimum heap element and rebalances the heap.
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER(KIND=valt), INTENT(IN)                     :: value

      DBCSR_ASSERT(heap%n > 0)
      heap%nodes(1)%node%value = value
      CALL bubble_down(heap, 1)
   END SUBROUTINE dbcsr_heap_reset_first

   PURE SUBROUTINE dbcsr_heap_swap(heap, e1, e2)
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER, INTENT(IN)                                :: e1, e2

      INTEGER(KIND=keyt)                                 :: key1, key2
      TYPE(dbcsr_heap_node)                              :: tmp_node

      key1 = heap%nodes(e1)%node%key
      key2 = heap%nodes(e2)%node%key

      tmp_node = heap%nodes(e1)%node
      heap%nodes(e1)%node = heap%nodes(e2)%node
      heap%nodes(e2)%node = tmp_node

      heap%index(key1) = e2
      heap%index(key2) = e1
   END SUBROUTINE dbcsr_heap_swap

   PURE SUBROUTINE dbcsr_heap_copy_node(heap, e1, e2)
      !! Sets node e1 to e2
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER, INTENT(IN)                                :: e1, e2

      INTEGER(KIND=keyt)                                 :: key1, key2

      key1 = heap%nodes(e1)%node%key
      key2 = heap%nodes(e2)%node%key

      heap%nodes(e1)%node = heap%nodes(e2)%node

      heap%index(key1) = 0
      heap%index(key2) = e1
   END SUBROUTINE dbcsr_heap_copy_node

   SUBROUTINE bubble_down(heap, first)
      !! Balances a heap by bubbling down from the given element.
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER, INTENT(IN)                                :: first

      INTEGER                                            :: e, left_child, right_child, smallest
      INTEGER(kind=valt)                                 :: left_child_value, min_value, &
                                                            right_child_value
      LOGICAL                                            :: all_done

!
      DBCSR_ASSERT(0 < first .AND. first <= heap%n)

      e = first
      all_done = .FALSE.
      ! Check whether we are finished, i.e,. whether the element to
      ! bubble down is childless.
      DO WHILE (e .LE. get_parent(heap%n) .AND. .NOT. all_done)
         ! Determines which node (current, left, or right child) has the
         ! smallest value.
         smallest = e
         min_value = get_value(heap, e)
         left_child = get_left_child(e)
         IF (left_child .LE. heap%n) THEN
            left_child_value = get_value(heap, left_child)
            IF (left_child_value .LT. min_value) THEN
               min_value = left_child_value
               smallest = left_child
            END IF
         END IF
         right_child = left_child + 1
         IF (right_child .LE. heap%n) THEN
            right_child_value = get_value(heap, right_child)
            IF (right_child_value .LT. min_value) THEN
               min_value = right_child_value
               smallest = right_child
            END IF
         END IF
         !
         CALL dbcsr_heap_swap(heap, e, smallest)
         IF (smallest .EQ. e) THEN
            all_done = .TRUE.
         ELSE
            e = smallest
         END IF
      END DO
   END SUBROUTINE bubble_down

   SUBROUTINE bubble_up(heap, first, new_pos)
      !! Balances a heap by bubbling up from the given element.
      TYPE(dbcsr_heap_type), INTENT(INOUT)               :: heap
      INTEGER, INTENT(IN)                                :: first
      INTEGER, INTENT(OUT)                               :: new_pos

      INTEGER                                            :: e, parent
      INTEGER(kind=valt)                                 :: my_value, parent_value
      LOGICAL                                            :: all_done

      DBCSR_ASSERT(0 < first .AND. first <= heap%n)

      e = first
      all_done = .FALSE.
      IF (e .GT. 1) THEN
         my_value = get_value(heap, e)
      END IF
      ! Check whether we are finished, i.e,. whether the element to
      ! bubble up is an orphan.
      new_pos = e
      DO WHILE (e .GT. 1 .AND. .NOT. all_done)
         ! Switches the parent and the current element if the current
         ! element's value is greater than the parent's value.
         parent = get_parent(e)
         parent_value = get_value(heap, parent)
         IF (my_value .LT. parent_value) THEN
            CALL dbcsr_heap_swap(heap, e, parent)
            e = parent
         ELSE
            all_done = .TRUE.
         END IF
      END DO
      new_pos = e
   END SUBROUTINE bubble_up

END MODULE dbcsr_min_heap