dbcsr_toollib.F Source File


Source Code

# 1 "/__w/dbcsr/dbcsr/src/utils/dbcsr_toollib.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_toollib
   !! Tools usually found in a standard library.

   USE dbcsr_array_sort, ONLY: dbcsr_1d_d_sort, &
                               dbcsr_1d_i4_sort, &
                               dbcsr_1d_i8_sort, &
                               dbcsr_1d_s_sort
   USE dbcsr_kinds, ONLY: int_4, &
                          int_8, &
                          real_8
#include "base/dbcsr_base_uses.f90"

   IMPLICIT NONE

   PRIVATE

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_toollib'

   ! Block sizes and arrays
   PUBLIC :: dbcsr_unpack_i8_2i4, make_coordinate_tuple
   PUBLIC :: swap
   ! math routines
   PUBLIC :: gcd, lcm
   ! utility routines
   PUBLIC :: sort, joaat_hash
   PUBLIC :: ordered_search
   PUBLIC :: atoi, atol, ator

   INTERFACE swap
      MODULE PROCEDURE iswap, bswap
   END INTERFACE

   INTERFACE sort
      MODULE PROCEDURE dbcsr_1d_i4_sort, dbcsr_1d_i8_sort
      MODULE PROCEDURE dbcsr_1d_s_sort, dbcsr_1d_d_sort
   END INTERFACE

CONTAINS

   ELEMENTAL FUNCTION make_coordinate_tuple(most, least) RESULT(tuple)
      INTEGER, INTENT(IN)                                :: most, least
      INTEGER(KIND=int_8)                                :: tuple

!tuple = IOR (ISHFT (most, 32), least)

      tuple = most
      tuple = IOR(ISHFT(tuple, 32), INT(least, int_8))
   END FUNCTION make_coordinate_tuple

   ELEMENTAL SUBROUTINE iswap(a, b)
      !! Swaps two integers

      INTEGER, INTENT(INOUT)                             :: a, b
         !! Integers to swap
         !! Integers to swap

      INTEGER                                            :: tmp

      tmp = a
      a = b
      b = tmp
   END SUBROUTINE iswap

   ELEMENTAL SUBROUTINE bswap(a, b)
      !! Swaps two logicals

      LOGICAL, INTENT(INOUT)                             :: a, b
         !! Logicals to swap
         !! Logicals to swap

      LOGICAL                                            :: tmp

      tmp = a
      a = b
      b = tmp
   END SUBROUTINE bswap

   SUBROUTINE dbcsr_unpack_i8_2i4(merged, array_upper, array_lower)
      !! Splits an array of int8 values into two int4 arrays.

      INTEGER(KIND=int_8), DIMENSION(:), INTENT(IN)      :: merged
         !! array of merged values
      INTEGER(KIND=int_4), DIMENSION(:), INTENT(OUT)     :: array_upper, array_lower
         !! array to fill with the upper bytes of the merged values
         !! array to fill with the lower bytes of the merged values

      INTEGER(KIND=int_8), PARAMETER                     :: lmask8 = 4294967295_int_8

      INTEGER                                            :: i

!
!   ---------------------------------------------------------------------------
! Lmask is used to filter in the lower 4 bytes and so its lower 32 bits are
! set to 1: lmask8 = 2^32-1.
! Umask is used to filter in the higher 4 bytes and so its higher 32 bits
! are set to 1: umask8 = 2^32-1 << 32
!lmask8 = 4294967295 ! 2^32-1
!umask8 = 18446744069414584320 ! (2^32-1) * 2^32 = (2^64-1)-(2^32-1)

      DO i = 1, SIZE(merged)
         array_upper(i) = INT(ISHFT(merged(i), -32), KIND=int_4)
         array_lower(i) = INT(IAND(merged(i), lmask8), KIND=int_4)
      END DO
   END SUBROUTINE dbcsr_unpack_i8_2i4

   ELEMENTAL FUNCTION gcd(a, b)
      INTEGER, INTENT(IN)                                :: a, b
      INTEGER                                            :: gcd

      INTEGER                                            :: aa, ab, l, rem, s

      aa = ABS(a)
      ab = ABS(b)
      IF (aa < ab) THEN
         s = aa
         l = ab
      ELSE
         s = ab
         l = aa
      END IF
      IF (s .NE. 0) THEN
         DO
            rem = MOD(l, s)
            IF (rem == 0) EXIT
            l = s
            s = rem
         END DO
         GCD = s
      ELSE
         GCD = l
      END IF
   END FUNCTION gcd

   ELEMENTAL FUNCTION lcm(a, b)
      INTEGER, INTENT(IN)                                :: a, b
      INTEGER                                            :: lcm

      INTEGER                                            :: tmp

      tmp = gcd(a, b)
      IF (tmp == 0) THEN
         lcm = 0
      ELSE
         ! could still overflow if the true lcm is larger than maxint
         lcm = ABS((a/tmp)*b)
      END IF
   END FUNCTION lcm

   FUNCTION joaat_hash(key) RESULT(hash_index)
      !! generates the hash of a string and the index in the table
      !! @note
      !! http://en.wikipedia.org/wiki/Hash_table
      !! http://www.burtleburtle.net/bob/hash/doobs.html
      !! However, since fortran doesn't have an unsigned 4 byte int
      !! we compute it using an integer with the appropriate range
      !! we return already the index in the table as a final result

      ! LIBXSMM: at least v1.9.0-6 is required
#if defined(__LIBXSMM) && TO_VERSION(1, 10) <= TO_VERSION(LIBXSMM_CONFIG_VERSION_MAJOR, LIBXSMM_CONFIG_VERSION_MINOR)
      USE libxsmm, ONLY: libxsmm_hash
      INTEGER, PARAMETER                                 :: seed = 0
      INTEGER, DIMENSION(:), INTENT(IN)                  :: key
         !! a string of any length
      INTEGER                                            :: hash_index
      hash_index = libxsmm_hash(key, seed)
#else
      INTEGER, DIMENSION(:), INTENT(IN)                  :: key
      INTEGER                                            :: hash_index

      INTEGER(KIND=int_8), PARAMETER                     :: b32 = 2_int_8**32 - 1_int_8

      INTEGER                                            :: i, j
      INTEGER(KIND=int_8)                                :: byte, hash

      hash = 0_int_8
      DO i = 1, SIZE(key)
         DO j = 0, 3
            byte = IAND(ISHFT(key(i), -j*8), 255)
            hash = IAND(hash + byte, b32)
            hash = IAND(hash + IAND(ISHFT(hash, 10), b32), b32)
            hash = IAND(IEOR(hash, IAND(ISHFT(hash, -6), b32)), b32)
         END DO
      END DO
      hash = IAND(hash + IAND(ISHFT(hash, 3), b32), b32)
      hash = IAND(IEOR(hash, IAND(ISHFT(hash, -11), b32)), b32)
      hash = IAND(hash + IAND(ISHFT(hash, 15), b32), b32)
      ! In fortran 4-byte-integers have only 31 bits because they are signed
      ! In fortran the rightmost (least significant) bit is in position 0
      hash_index = INT(IBCLR(hash, 31))
#endif
   END FUNCTION joaat_hash

   PURE SUBROUTINE ordered_search(array, key, loc, found, lb, ub)
      !! search a value in an ordered array of indices
      INTEGER, DIMENSION(:), INTENT(IN)                  :: array
      INTEGER, INTENT(IN)                                :: key
      INTEGER, INTENT(OUT)                               :: loc
      LOGICAL, INTENT(OUT)                               :: found
      INTEGER, INTENT(IN), OPTIONAL                      :: lb, ub

      INTEGER                                            :: high, low, val

      found = .FALSE.
      IF (PRESENT(lb)) THEN
         low = lb
      ELSE
         low = LBOUND(array, 1)
      END IF
      IF (PRESENT(ub)) THEN
         high = ub
      ELSE
         high = UBOUND(array, 1)
      END IF
      loc = (low + high)/2
      DO WHILE (loc .GE. low .AND. loc .LE. high)
         val = array(loc)
         IF (val .EQ. key) THEN
            found = .TRUE.
            EXIT
         ELSEIF (val .LT. key) THEN
            low = loc + 1
         ELSE
            high = loc - 1
         END IF
         loc = (low + high)/2
      END DO
   END SUBROUTINE ordered_search

   FUNCTION atoi(a)
      CHARACTER(len=*), INTENT(in)                       :: a
      INTEGER                                            :: atoi

      READ (a, '(I9)') atoi
   END FUNCTION atoi

   FUNCTION atol(a)
      CHARACTER(len=*), INTENT(in)                       :: a
      LOGICAL                                            :: atol

      READ (a, '(L1)') atol
   END FUNCTION atol

   FUNCTION ator(a)
      CHARACTER(len=*), INTENT(in)                       :: a
      REAL(real_8)                                       :: ator

      READ (a, '(E26.15)') ator
   END FUNCTION ator

END MODULE dbcsr_toollib