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