1!--------------------------------------------------------------------------------------------------!
2!   CP2K: A general program to perform molecular dynamics simulations                              !
3!   Copyright (C) 2000 - 2019  CP2K developers group                                               !
4!--------------------------------------------------------------------------------------------------!
5
6MODULE qs_fb_matrix_data_types
7
8   USE kinds,                           ONLY: dp,&
9                                              int_8
10   USE qs_fb_buffer_types,              ONLY: fb_buffer_add,&
11                                              fb_buffer_create,&
12                                              fb_buffer_d_obj,&
13                                              fb_buffer_get,&
14                                              fb_buffer_has_data,&
15                                              fb_buffer_nullify,&
16                                              fb_buffer_release,&
17                                              fb_buffer_replace
18   USE qs_fb_hash_table_types,          ONLY: fb_hash_table_add,&
19                                              fb_hash_table_create,&
20                                              fb_hash_table_get,&
21                                              fb_hash_table_has_data,&
22                                              fb_hash_table_nullify,&
23                                              fb_hash_table_obj,&
24                                              fb_hash_table_release
25#include "./base/base_uses.f90"
26
27   IMPLICIT NONE
28
29   PRIVATE
30
31   ! public types
32   PUBLIC :: fb_matrix_data_obj
33
34   ! public methods
35   !API
36   PUBLIC :: fb_matrix_data_add, &
37             fb_matrix_data_create, &
38             fb_matrix_data_get, &
39             fb_matrix_data_has_data, &
40             fb_matrix_data_nullify, &
41             fb_matrix_data_release
42
43   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_fb_matrix_data_types'
44   INTEGER, PRIVATE, SAVE :: last_fb_matrix_data_id = 0
45
46   ! Parameters related to automatic resizing of matrix_data:
47   INTEGER, PARAMETER, PRIVATE :: EXPAND_FACTOR = 2
48
49! **************************************************************************************************
50!> \brief data type for storing a list of matrix blocks
51!> \param nmax      : maximum number of blocks can be stored
52!> \param nblks     : number of blocks currently stored
53!> \param nencode   : integer used to encode global block coordinate (row, col)
54!>                    into a single combined integer
55!> \param ind       : hash table maping the global combined index of the blocks
56!>                    to the location in the data area
57!> \param blks      : data area, well the matrix elements are actuaally stored
58!> \param lds       : leading dimensions of each block
59!> \param id_nr     : unique id for the object
60!> \param ref_count : reference counter for the object
61!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
62! **************************************************************************************************
63   TYPE fb_matrix_data_data
64      INTEGER :: id_nr, ref_count
65      INTEGER :: nmax
66      INTEGER :: nblks
67      INTEGER :: nencode
68      TYPE(fb_hash_table_obj) :: ind
69      TYPE(fb_buffer_d_obj) :: blks
70      INTEGER, DIMENSION(:), POINTER :: lds => NULL()
71   END TYPE fb_matrix_data_data
72
73! **************************************************************************************************
74!> \brief the object container which allows for the creation of an array
75!>        of pointers to fb_matrix_data objects
76!> \param obj : pointer to the fb_matrix_data object
77!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
78! **************************************************************************************************
79   TYPE fb_matrix_data_obj
80      TYPE(fb_matrix_data_data), POINTER, PRIVATE :: obj => NULL()
81   END TYPE fb_matrix_data_obj
82
83CONTAINS
84
85! **************************************************************************************************
86!> \brief Add a matrix block to a fb_matrix_data object
87!> \param matrix_data : the fb_matrix_data object
88!> \param row         : block row index of the matrix block
89!> \param col         : block col index of the matrix block
90!> \param blk         : the matrix block to add
91!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
92! **************************************************************************************************
93   SUBROUTINE fb_matrix_data_add(matrix_data, row, col, blk)
94      TYPE(fb_matrix_data_obj), INTENT(INOUT)            :: matrix_data
95      INTEGER, INTENT(IN)                                :: row, col
96      REAL(KIND=dp), DIMENSION(:, :), INTENT(IN)         :: blk
97
98      CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_add', &
99         routineP = moduleN//':'//routineN
100
101      INTEGER                                            :: existing_ii, ii, ncols, nrows, old_nblks
102      INTEGER(KIND=int_8)                                :: pair_ind
103      INTEGER, DIMENSION(:), POINTER                     :: new_lds
104      LOGICAL                                            :: check_ok, found
105
106      check_ok = fb_matrix_data_has_data(matrix_data)
107      CPASSERT(check_ok)
108      NULLIFY (new_lds)
109      nrows = SIZE(blk, 1)
110      ncols = SIZE(blk, 2)
111      ! first check if the block already exists in matrix_data
112      pair_ind = fb_matrix_data_encode_pair(row, col, matrix_data%obj%nencode)
113      CALL fb_hash_table_get(matrix_data%obj%ind, pair_ind, existing_ii, found)
114      IF (found) THEN
115         CALL fb_buffer_replace(matrix_data%obj%blks, existing_ii, RESHAPE(blk, (/nrows*ncols/)))
116      ELSE
117         old_nblks = matrix_data%obj%nblks
118         matrix_data%obj%nblks = old_nblks + 1
119         ii = matrix_data%obj%nblks
120         ! resize lds if necessary
121         IF (SIZE(matrix_data%obj%lds) .LT. ii) THEN
122            ALLOCATE (new_lds(ii*EXPAND_FACTOR))
123            new_lds = 0
124            new_lds(1:old_nblks) = matrix_data%obj%lds(1:old_nblks)
125            DEALLOCATE (matrix_data%obj%lds)
126            matrix_data%obj%lds => new_lds
127         END IF
128         ! add data block
129         matrix_data%obj%lds(ii) = nrows
130         CALL fb_buffer_add(matrix_data%obj%blks, RESHAPE(blk, (/nrows*ncols/)))
131         ! record blk index in the index table
132         CALL fb_hash_table_add(matrix_data%obj%ind, pair_ind, ii)
133      END IF
134   END SUBROUTINE fb_matrix_data_add
135
136! **************************************************************************************************
137!> \brief Associates one fb_matrix_data object to another
138!> \param a : the fb_matrix_data object to be associated
139!> \param b : the fb_matrix_data object that a is to be associated to
140!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
141! **************************************************************************************************
142   SUBROUTINE fb_matrix_data_associate(a, b)
143      TYPE(fb_matrix_data_obj), INTENT(OUT)              :: a
144      TYPE(fb_matrix_data_obj), INTENT(IN)               :: b
145
146      a%obj => b%obj
147   END SUBROUTINE fb_matrix_data_associate
148
149! **************************************************************************************************
150!> \brief Creates and initialises an empty fb_matrix_data object of a given size
151!> \param matrix_data : the fb_matrix_data object, its content must be NULL
152!>                      and cannot be UNDEFINED
153!> \param nmax        : max number of matrix blks can be stored
154!> \param nencode ...
155!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
156! **************************************************************************************************
157   SUBROUTINE fb_matrix_data_create(matrix_data, nmax, nencode)
158      TYPE(fb_matrix_data_obj), INTENT(INOUT)            :: matrix_data
159      INTEGER, INTENT(IN)                                :: nmax, nencode
160
161      CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_create', &
162         routineP = moduleN//':'//routineN
163
164      LOGICAL                                            :: check_ok
165
166      check_ok = .NOT. fb_matrix_data_has_data(matrix_data)
167      CPASSERT(check_ok)
168      ALLOCATE (matrix_data%obj)
169      CALL fb_hash_table_nullify(matrix_data%obj%ind)
170      CALL fb_buffer_nullify(matrix_data%obj%blks)
171      NULLIFY (matrix_data%obj%lds)
172      matrix_data%obj%nmax = 0
173      matrix_data%obj%nblks = 0
174      matrix_data%obj%nencode = nencode
175      CALL fb_matrix_data_init(matrix_data=matrix_data, &
176                               nmax=nmax, &
177                               nencode=nencode)
178      ! book keeping stuff
179      matrix_data%obj%ref_count = 1
180      matrix_data%obj%id_nr = last_fb_matrix_data_id + 1
181      last_fb_matrix_data_id = matrix_data%obj%id_nr
182   END SUBROUTINE fb_matrix_data_create
183
184! **************************************************************************************************
185!> \brief retrieve a matrix block from a matrix_data object
186!> \param matrix_data : the fb_matrix_data object
187!> \param row         : row index
188!> \param col         : col index
189!> \param blk_p       : pointer to the block in the fb_matrix_data object
190!> \param found       : if the requested block exists in the fb_matrix_data
191!>                      object
192!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
193! **************************************************************************************************
194   SUBROUTINE fb_matrix_data_get(matrix_data, row, col, blk_p, found)
195      TYPE(fb_matrix_data_obj), INTENT(IN)               :: matrix_data
196      INTEGER, INTENT(IN)                                :: row, col
197      REAL(KIND=dp), DIMENSION(:, :), POINTER            :: blk_p
198      LOGICAL, INTENT(OUT)                               :: found
199
200      CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_get', &
201         routineP = moduleN//':'//routineN
202
203      INTEGER                                            :: ind_in_blks
204      INTEGER(KIND=int_8)                                :: pair_ind
205      LOGICAL                                            :: check_ok
206
207      check_ok = fb_matrix_data_has_data(matrix_data)
208      CPASSERT(check_ok)
209      pair_ind = fb_matrix_data_encode_pair(row, col, matrix_data%obj%nencode)
210      CALL fb_hash_table_get(matrix_data%obj%ind, pair_ind, ind_in_blks, found)
211      IF (found) THEN
212         CALL fb_buffer_get(buffer=matrix_data%obj%blks, &
213                            i_slice=ind_in_blks, &
214                            data_2d=blk_p, &
215                            data_2d_ld=matrix_data%obj%lds(ind_in_blks))
216      ELSE
217         NULLIFY (blk_p)
218      END IF
219   END SUBROUTINE fb_matrix_data_get
220
221! **************************************************************************************************
222!> \brief check if the object has data associated to it
223!> \param matrix_data : the fb_matrix_data object in question
224!> \return : true if matrix_data%obj is associated, false otherwise
225!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
226! **************************************************************************************************
227   PURE FUNCTION fb_matrix_data_has_data(matrix_data) RESULT(res)
228      TYPE(fb_matrix_data_obj), INTENT(IN)               :: matrix_data
229      LOGICAL                                            :: res
230
231      res = ASSOCIATED(matrix_data%obj)
232   END FUNCTION fb_matrix_data_has_data
233
234! **************************************************************************************************
235!> \brief Initialises a fb_matrix_data object of a given size
236!> \param matrix_data : the fb_matrix_data object, its content must be NULL
237!>                      and cannot be UNDEFINED
238!> \param nmax        : max number of matrix blocks can be stored, default is
239!>                      to use the existing number of blocks in matrix_data
240!> \param nencode     : integer used to incode (row, col) to a single combined
241!>                      index
242!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
243! **************************************************************************************************
244   SUBROUTINE fb_matrix_data_init(matrix_data, nmax, nencode)
245      TYPE(fb_matrix_data_obj), INTENT(INOUT)            :: matrix_data
246      INTEGER, INTENT(IN), OPTIONAL                      :: nmax, nencode
247
248      CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_init', &
249         routineP = moduleN//':'//routineN
250
251      INTEGER                                            :: my_nmax
252      LOGICAL                                            :: check_ok
253
254      check_ok = fb_matrix_data_has_data(matrix_data)
255      CPASSERT(check_ok)
256      my_nmax = matrix_data%obj%nmax
257      IF (PRESENT(nmax)) my_nmax = nmax
258      my_nmax = MAX(my_nmax, 1)
259      IF (fb_hash_table_has_data(matrix_data%obj%ind)) THEN
260         CALL fb_hash_table_release(matrix_data%obj%ind)
261      END IF
262      CALL fb_hash_table_create(matrix_data%obj%ind, my_nmax)
263      IF (fb_buffer_has_data(matrix_data%obj%blks)) THEN
264         CALL fb_buffer_release(matrix_data%obj%blks)
265      END IF
266      CALL fb_buffer_create(buffer=matrix_data%obj%blks)
267      IF (ASSOCIATED(matrix_data%obj%lds)) THEN
268         DEALLOCATE (matrix_data%obj%lds)
269      END IF
270      ALLOCATE (matrix_data%obj%lds(0))
271      matrix_data%obj%nblks = 0
272      IF (PRESENT(nencode)) matrix_data%obj%nencode = nencode
273   END SUBROUTINE fb_matrix_data_init
274
275! **************************************************************************************************
276!> \brief Nullifies a fb_matrix_data object
277!> \param matrix_data : the fb_matrix_data object
278!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
279! **************************************************************************************************
280   PURE SUBROUTINE fb_matrix_data_nullify(matrix_data)
281      TYPE(fb_matrix_data_obj), INTENT(INOUT)            :: matrix_data
282
283      NULLIFY (matrix_data%obj)
284   END SUBROUTINE fb_matrix_data_nullify
285
286! **************************************************************************************************
287!> \brief releases given object
288!> \param matrix_data : the fb_matrix_data object in question
289!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
290! **************************************************************************************************
291   SUBROUTINE fb_matrix_data_release(matrix_data)
292      TYPE(fb_matrix_data_obj), INTENT(INOUT)            :: matrix_data
293
294      CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_release', &
295         routineP = moduleN//':'//routineN
296
297      LOGICAL                                            :: check_ok
298
299      IF (ASSOCIATED(matrix_data%obj)) THEN
300         check_ok = matrix_data%obj%ref_count > 0
301         CPASSERT(check_ok)
302         matrix_data%obj%ref_count = matrix_data%obj%ref_count - 1
303         IF (matrix_data%obj%ref_count == 0) THEN
304            matrix_data%obj%ref_count = 1
305            IF (fb_hash_table_has_data(matrix_data%obj%ind)) THEN
306               CALL fb_hash_table_release(matrix_data%obj%ind)
307            END IF
308            IF (fb_buffer_has_data(matrix_data%obj%blks)) THEN
309               CALL fb_buffer_release(matrix_data%obj%blks)
310            END IF
311            IF (ASSOCIATED(matrix_data%obj%lds)) THEN
312               DEALLOCATE (matrix_data%obj%lds)
313            END IF
314            matrix_data%obj%ref_count = 0
315            DEALLOCATE (matrix_data%obj)
316         END IF
317      ELSE
318         NULLIFY (matrix_data%obj)
319      END IF
320   END SUBROUTINE fb_matrix_data_release
321
322! **************************************************************************************************
323!> \brief retains given object
324!> \param matrix_data : the fb_matrix_data object in question
325!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
326! **************************************************************************************************
327   SUBROUTINE fb_matrix_data_retain(matrix_data)
328      TYPE(fb_matrix_data_obj), INTENT(INOUT)            :: matrix_data
329
330      CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_retain', &
331         routineP = moduleN//':'//routineN
332
333      LOGICAL                                            :: check_ok
334
335      check_ok = ASSOCIATED(matrix_data%obj)
336      CPASSERT(check_ok)
337      check_ok = matrix_data%obj%ref_count > 0
338      CPASSERT(check_ok)
339      matrix_data%obj%ref_count = matrix_data%obj%ref_count + 1
340   END SUBROUTINE fb_matrix_data_retain
341
342! **************************************************************************************************
343!> \brief outputs the current information about fb_matrix_data object
344!> \param matrix_data : the fb_matrix_data object
345!> \param nmax        : outputs fb_matrix_data%obj%nmax
346!> \param nblks       : outputs fb_matrix_data%obj%nblks
347!> \param nencode     : outputs fb_matrix_data%obj%nencode
348!> \param blk_sizes   : blk_sizes(ii,jj) gives size of jj-th dim of the
349!>                      ii-th block stored
350!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
351! **************************************************************************************************
352   SUBROUTINE fb_matrix_data_status(matrix_data, nmax, nblks, nencode, blk_sizes)
353      TYPE(fb_matrix_data_obj), INTENT(INOUT)            :: matrix_data
354      INTEGER, INTENT(OUT), OPTIONAL                     :: nmax, nblks, nencode
355      INTEGER, DIMENSION(:, :), INTENT(OUT), OPTIONAL    :: blk_sizes
356
357      CHARACTER(len=*), PARAMETER :: routineN = 'fb_matrix_data_status', &
358         routineP = moduleN//':'//routineN
359
360      INTEGER                                            :: ii
361      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: buffer_sizes
362      LOGICAL                                            :: check_ok
363
364      check_ok = fb_matrix_data_has_data(matrix_data)
365      CPASSERT(check_ok)
366      IF (PRESENT(nmax)) nmax = matrix_data%obj%nmax
367      IF (PRESENT(nblks)) nblks = matrix_data%obj%nblks
368      IF (PRESENT(nencode)) nencode = matrix_data%obj%nencode
369      IF (PRESENT(blk_sizes)) THEN
370         check_ok = (SIZE(blk_sizes, 1) .GE. matrix_data%obj%nblks .AND. &
371                     SIZE(blk_sizes, 2) .GE. 2)
372         CPASSERT(check_ok)
373         blk_sizes(:, :) = 0
374         ALLOCATE (buffer_sizes(matrix_data%obj%nblks))
375         CALL fb_buffer_get(buffer=matrix_data%obj%blks, &
376                            sizes=buffer_sizes)
377         DO ii = 1, matrix_data%obj%nblks
378            blk_sizes(ii, 1) = matrix_data%obj%lds(ii)
379            blk_sizes(ii, 2) = buffer_sizes(ii)/matrix_data%obj%lds(ii)
380         END DO
381         DEALLOCATE (buffer_sizes)
382      END IF
383   END SUBROUTINE fb_matrix_data_status
384
385! **************************************************************************************************
386!> \brief Encodes (row, col) index pair into a single combined index
387!> \param row     : row index (assume to start counting from 1)
388!> \param col     : col index (assume to start counting from 1)
389!> \param nencode : integer used for encoding
390!> \return : the returned value
391!> \author Lianheng Tong (LT) lianheng.tong@kcl.ac.uk
392! **************************************************************************************************
393   PURE FUNCTION fb_matrix_data_encode_pair(row, col, nencode) &
394      RESULT(pair_ind)
395      INTEGER, INTENT(IN)                                :: row, col, nencode
396      INTEGER(KIND=int_8)                                :: pair_ind
397
398      INTEGER(KIND=int_8)                                :: col_8, nencode_8, row_8
399
400      row_8 = INT(row, int_8)
401      col_8 = INT(col, int_8)
402      nencode_8 = INT(nencode, int_8)
403      pair_ind = (row_8 - 1_int_8)*nencode_8 + (col_8 - 1_int_8) + 1
404   END FUNCTION fb_matrix_data_encode_pair
405
406END MODULE qs_fb_matrix_data_types
407