1!--------------------------------------------------------------------------------------------------! 2! Copyright (C) by the DBCSR developers group - All rights reserved ! 3! This file is part of the DBCSR library. ! 4! ! 5! For information on the license, see the LICENSE file. ! 6! For further information please visit https://dbcsr.cp2k.org ! 7! SPDX-License-Identifier: GPL-2.0+ ! 8!--------------------------------------------------------------------------------------------------! 9 10MODULE dbcsr_array_types 11 !! Array objects with reference counting. 12 13#include "base/dbcsr_base_uses.f90" 14#if TO_VERSION(1, 11) <= TO_VERSION(LIBXSMM_CONFIG_VERSION_MAJOR, LIBXSMM_CONFIG_VERSION_MINOR) 15 USE libxsmm, ONLY: libxsmm_diff 16# define PURE_ARRAY_EQUALITY 17#else 18# define PURE_ARRAY_EQUALITY PURE 19#endif 20 21 IMPLICIT NONE 22 PRIVATE 23 24 PUBLIC :: array_i1d_obj 25 PUBLIC :: array_new, & 26 array_hold, & 27 array_release, & 28 array_nullify, & 29 array_exists 30 PUBLIC :: array_data, & 31 array_size, & 32 array_equality 33 PUBLIC :: array_get 34 35 INTERFACE array_new 36 MODULE PROCEDURE array_new_i1d, array_new_i1d_lb 37 END INTERFACE 38 INTERFACE array_hold 39 MODULE PROCEDURE array_hold_i1d 40 END INTERFACE 41 INTERFACE array_release 42 MODULE PROCEDURE array_release_i1d 43 END INTERFACE 44 INTERFACE array_nullify 45 MODULE PROCEDURE array_nullify_i1d 46 END INTERFACE 47 INTERFACE array_exists 48 MODULE PROCEDURE array_exists_i1d 49 END INTERFACE 50 INTERFACE array_data 51 MODULE PROCEDURE array_data_i1d 52 END INTERFACE 53 INTERFACE array_size 54 MODULE PROCEDURE array_size_i1d 55 END INTERFACE 56 INTERFACE array_equality 57 MODULE PROCEDURE array_equality_i1 58 MODULE PROCEDURE array_equality_i1d 59 END INTERFACE 60 INTERFACE array_get 61 MODULE PROCEDURE array_get_i1d 62 MODULE PROCEDURE array_get_i1 63 END INTERFACE 64 65 TYPE array_i1d_type 66 INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: DATA => Null() 67 INTEGER :: refcount = 0 68 END TYPE array_i1d_type 69 70 TYPE array_i1d_obj 71 TYPE(array_i1d_type), POINTER :: low => Null() 72 END TYPE array_i1d_obj 73 74CONTAINS 75 76 SUBROUTINE array_new_i1d(array, DATA, gift) 77 TYPE(array_i1d_obj), INTENT(OUT) :: array 78 INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: DATA 79 LOGICAL, INTENT(IN), OPTIONAL :: gift 80 81 INTEGER :: lb, ub 82 LOGICAL :: g 83 84 ALLOCATE (array%low) 85 array%low%refcount = 1 86 g = .FALSE. 87 IF (PRESENT(gift)) g = gift 88 IF (g) THEN 89 array%low%data => DATA 90 NULLIFY (DATA) 91 ELSE 92 lb = LBOUND(DATA, 1) 93 ub = UBOUND(DATA, 1) 94 ALLOCATE (array%low%data(lb:ub)) 95 array%low%data(:) = DATA(:) 96 ENDIF 97 END SUBROUTINE array_new_i1d 98 99 SUBROUTINE array_new_i1d_lb(array, DATA, lb) 100 TYPE(array_i1d_obj), INTENT(OUT) :: array 101 INTEGER, DIMENSION(:), INTENT(IN) :: DATA 102 INTEGER, INTENT(IN) :: lb 103 104 INTEGER :: ub 105 106 ALLOCATE (array%low) 107 array%low%refcount = 1 108 ub = lb + SIZE(DATA) - 1 109 ALLOCATE (array%low%data(lb:ub)) 110 array%low%data(:) = DATA(:) 111 END SUBROUTINE array_new_i1d_lb 112 113 SUBROUTINE array_hold_i1d(array) 114 TYPE(array_i1d_obj), INTENT(INOUT) :: array 115!$OMP ATOMIC 116 array%low%refcount = array%low%refcount + 1 117 END SUBROUTINE array_hold_i1d 118 119 SUBROUTINE array_release_i1d(array) 120 TYPE(array_i1d_obj), INTENT(INOUT) :: array 121 122 IF (ASSOCIATED(array%low)) THEN 123 array%low%refcount = array%low%refcount - 1 124 IF (array%low%refcount .EQ. 0) THEN 125 DEALLOCATE (array%low%data) 126 DEALLOCATE (array%low) 127 ENDIF 128 ENDIF 129 END SUBROUTINE array_release_i1d 130 131 PURE SUBROUTINE array_nullify_i1d(array) 132 TYPE(array_i1d_obj), INTENT(INOUT) :: array 133 134 NULLIFY (array%low) 135 END SUBROUTINE array_nullify_i1d 136 137 PURE FUNCTION array_exists_i1d(array) RESULT(array_exists) 138 TYPE(array_i1d_obj), INTENT(IN) :: array 139 LOGICAL :: array_exists 140 141 array_exists = ASSOCIATED(array%low) 142 IF (array_exists) array_exists = array%low%refcount .GT. 0 143 END FUNCTION array_exists_i1d 144 145 FUNCTION array_data_i1d(array) RESULT(DATA) 146 TYPE(array_i1d_obj), INTENT(IN) :: array 147 INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: DATA 148 149 IF (ASSOCIATED(array%low)) THEN 150 DATA => array%low%data 151 ELSE 152 NULLIFY (DATA) 153 ENDIF 154 END FUNCTION array_data_i1d 155 156 PURE FUNCTION array_size_i1d(array) RESULT(the_size) 157 TYPE(array_i1d_obj), INTENT(IN) :: array 158 INTEGER :: the_size 159 160 IF (ASSOCIATED(array%low)) THEN 161 the_size = SIZE(array%low%data) 162 ELSE 163 the_size = 0 164 ENDIF 165 END FUNCTION array_size_i1d 166 167 PURE_ARRAY_EQUALITY FUNCTION array_equality_i1(array1, array2) RESULT(are_equal) 168 INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: array1, array2 169 LOGICAL :: are_equal 170 171 are_equal = .FALSE. 172 IF (ASSOCIATED(array1) .AND. ASSOCIATED(array2)) THEN 173#if TO_VERSION(1, 11) <= TO_VERSION(LIBXSMM_CONFIG_VERSION_MAJOR, LIBXSMM_CONFIG_VERSION_MINOR) 174 are_equal = .NOT. libxsmm_diff(array1, array2) 175#else 176 IF (SIZE(array1) .NE. SIZE(array2)) RETURN 177 are_equal = ALL(array1 .EQ. array2) 178#endif 179 ENDIF 180 END FUNCTION array_equality_i1 181 182 PURE_ARRAY_EQUALITY FUNCTION array_equality_i1d(array1, array2) RESULT(are_equal) 183 TYPE(array_i1d_obj), INTENT(IN) :: array1, array2 184 LOGICAL :: are_equal 185 186 are_equal = .FALSE. 187 IF (ASSOCIATED(array1%low) .AND. ASSOCIATED(array2%low)) THEN 188#if TO_VERSION(1, 11) <= TO_VERSION(LIBXSMM_CONFIG_VERSION_MAJOR, LIBXSMM_CONFIG_VERSION_MINOR) 189 are_equal = .NOT. libxsmm_diff(array1%low%data, array2%low%data) 190#else 191 IF (SIZE(array1%low%data) .NE. SIZE(array2%low%data)) RETURN 192 are_equal = ALL(array1%low%data .EQ. array2%low%data) 193#endif 194 ENDIF 195 END FUNCTION array_equality_i1d 196 197 PURE FUNCTION array_get_i1d(array, index1) RESULT(value) 198 TYPE(array_i1d_obj), INTENT(IN) :: array 199 INTEGER, INTENT(IN) :: index1 200 INTEGER :: value 201 202 value = array%low%data(index1) 203 END FUNCTION array_get_i1d 204 205 PURE FUNCTION array_get_i1(array, index1) RESULT(value) 206 INTEGER, DIMENSION(:), INTENT(IN), POINTER :: array 207 INTEGER, INTENT(IN) :: index1 208 INTEGER :: value 209 210 value = array(index1) 211 END FUNCTION array_get_i1 212END MODULE dbcsr_array_types 213