Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: BSD-3-Clause !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : MODULE dbm_api
9 : USE ISO_C_BINDING, ONLY: C_ASSOCIATED, C_BOOL, C_CHAR, C_DOUBLE, C_F_POINTER, C_FUNLOC, C_FUNPTR, &
10 : C_INT, C_INT64_T, C_NULL_CHAR, C_NULL_PTR, C_PTR
11 : USE kinds, ONLY: default_string_length, &
12 : dp, &
13 : int_8
14 : USE message_passing, ONLY: mp_cart_type, &
15 : mp_comm_type
16 : USE string_utilities, ONLY: strlcpy_c2f
17 :
18 : ! Uncomment the following line to enable validation.
19 : !#define DBM_VALIDATE_AGAINST_DBCSR
20 : #define DBM_VALIDATE_NBLOCKS_MATCH .TRUE.
21 : #define DBM_VALIDATE_THRESHOLD 5e-10_dp
22 :
23 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
24 : USE dbcsr_block_access, ONLY: dbcsr_get_block_p, &
25 : dbcsr_put_block, &
26 : dbcsr_reserve_blocks
27 : USE dbcsr_dist_methods, ONLY: dbcsr_distribution_col_dist, &
28 : dbcsr_distribution_hold, &
29 : dbcsr_distribution_new, &
30 : dbcsr_distribution_release, &
31 : dbcsr_distribution_row_dist
32 : USE dbcsr_dist_operations, ONLY: dbcsr_get_stored_coordinates
33 : USE dbcsr_dist_util, ONLY: dbcsr_checksum
34 : USE dbcsr_iterator_operations, ONLY: dbcsr_iterator_blocks_left, &
35 : dbcsr_iterator_next_block, &
36 : dbcsr_iterator_start, &
37 : dbcsr_iterator_stop
38 : USE dbcsr_methods, ONLY: dbcsr_col_block_sizes, &
39 : dbcsr_get_num_blocks, &
40 : dbcsr_get_nze, &
41 : dbcsr_mp_release, &
42 : dbcsr_release, &
43 : dbcsr_row_block_sizes
44 : USE dbcsr_mp_methods, ONLY: dbcsr_mp_new
45 : USE dbcsr_multiply_api, ONLY: dbcsr_multiply
46 : USE dbcsr_operations, ONLY: dbcsr_add, &
47 : dbcsr_clear, &
48 : dbcsr_copy, &
49 : dbcsr_filter, &
50 : dbcsr_get_info, &
51 : dbcsr_maxabs, &
52 : dbcsr_scale, &
53 : dbcsr_zero
54 : USE dbcsr_transformations, ONLY: dbcsr_redistribute
55 : USE dbcsr_types, ONLY: dbcsr_distribution_obj, &
56 : dbcsr_iterator, &
57 : dbcsr_mp_obj, &
58 : dbcsr_no_transpose, &
59 : dbcsr_transpose, &
60 : dbcsr_type, &
61 : dbcsr_type_no_symmetry, &
62 : dbcsr_type_real_8
63 : USE dbcsr_work_operations, ONLY: dbcsr_create, &
64 : dbcsr_finalize
65 : USE dbcsr_data_methods, ONLY: dbcsr_scalar
66 : #endif
67 :
68 : #include "../base/base_uses.f90"
69 :
70 : IMPLICIT NONE
71 :
72 : PRIVATE
73 :
74 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbm_api'
75 :
76 : PUBLIC :: dbm_distribution_obj
77 : PUBLIC :: dbm_distribution_new
78 : PUBLIC :: dbm_distribution_hold
79 : PUBLIC :: dbm_distribution_release
80 : PUBLIC :: dbm_distribution_col_dist
81 : PUBLIC :: dbm_distribution_row_dist
82 :
83 : PUBLIC :: dbm_iterator
84 : PUBLIC :: dbm_iterator_start
85 : PUBLIC :: dbm_iterator_stop
86 : PUBLIC :: dbm_iterator_num_blocks
87 : PUBLIC :: dbm_iterator_blocks_left
88 : PUBLIC :: dbm_iterator_next_block
89 :
90 : PUBLIC :: dbm_type
91 : PUBLIC :: dbm_release
92 : PUBLIC :: dbm_create
93 : PUBLIC :: dbm_create_from_template
94 : PUBLIC :: dbm_clear
95 : PUBLIC :: dbm_scale
96 : PUBLIC :: dbm_get_block_p
97 : PUBLIC :: dbm_put_block
98 : PUBLIC :: dbm_reserve_blocks
99 : PUBLIC :: dbm_filter
100 : PUBLIC :: dbm_finalize
101 : PUBLIC :: dbm_multiply
102 : PUBLIC :: dbm_redistribute
103 : PUBLIC :: dbm_copy
104 : PUBLIC :: dbm_add
105 : PUBLIC :: dbm_maxabs
106 : PUBLIC :: dbm_zero
107 : PUBLIC :: dbm_checksum
108 : PUBLIC :: dbm_get_name
109 : PUBLIC :: dbm_get_distribution
110 : PUBLIC :: dbm_get_num_blocks
111 : PUBLIC :: dbm_get_nze
112 : PUBLIC :: dbm_get_stored_coordinates
113 : PUBLIC :: dbm_get_row_block_sizes
114 : PUBLIC :: dbm_get_col_block_sizes
115 : PUBLIC :: dbm_get_local_rows
116 : PUBLIC :: dbm_get_local_cols
117 :
118 : PUBLIC :: dbm_library_init
119 : PUBLIC :: dbm_library_finalize
120 : PUBLIC :: dbm_library_print_stats
121 :
122 : TYPE dbm_distribution_obj
123 : PRIVATE
124 : TYPE(C_PTR) :: c_ptr = C_NULL_PTR
125 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
126 : TYPE(dbcsr_distribution_obj) :: dbcsr
127 : #endif
128 : END TYPE dbm_distribution_obj
129 :
130 : TYPE dbm_type
131 : PRIVATE
132 : TYPE(C_PTR) :: c_ptr = C_NULL_PTR
133 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
134 : TYPE(dbcsr_type) :: dbcsr
135 : #endif
136 : END TYPE dbm_type
137 :
138 : TYPE dbm_iterator
139 : PRIVATE
140 : TYPE(C_PTR) :: c_ptr = C_NULL_PTR
141 : END TYPE dbm_iterator
142 :
143 : CONTAINS
144 :
145 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
146 : ! **************************************************************************************************
147 : !> \brief Compates the given DBM matrix against its shadow DBCSR matrics.
148 : !> \param matrix ...
149 : !> \author Ole Schuett
150 : ! **************************************************************************************************
151 : SUBROUTINE validate(matrix)
152 : TYPE(dbm_type), INTENT(IN) :: matrix
153 :
154 : INTEGER :: col, col_size, col_size_dbcsr, i, j, &
155 : num_blocks, num_blocks_dbcsr, &
156 : num_blocks_diff, row, row_size, &
157 : row_size_dbcsr
158 : INTEGER, ALLOCATABLE, DIMENSION(:) :: local_cols, local_rows
159 : LOGICAL :: transposed
160 : REAL(dp) :: norm2, rel_diff
161 : REAL(dp), DIMENSION(:, :), POINTER :: block, block_dbcsr
162 : TYPE(C_PTR) :: block_c
163 : TYPE(dbcsr_iterator) :: iter
164 : INTERFACE
165 : SUBROUTINE dbm_get_block_p_c(matrix, row, col, block, row_size, col_size) &
166 : BIND(C, name="dbm_get_block_p")
167 : IMPORT :: C_PTR, C_INT
168 : TYPE(C_PTR), VALUE :: matrix
169 : INTEGER(kind=C_INT), VALUE :: row
170 : INTEGER(kind=C_INT), VALUE :: col
171 : TYPE(C_PTR) :: block
172 : INTEGER(kind=C_INT) :: row_size
173 : INTEGER(kind=C_INT) :: col_size
174 : END SUBROUTINE dbm_get_block_p_c
175 : END INTERFACE
176 :
177 : ! Call some getters to run their validation code.
178 : CALL dbm_get_local_rows(matrix, local_rows)
179 : CALL dbm_get_local_cols(matrix, local_cols)
180 :
181 : num_blocks_dbcsr = dbcsr_get_num_blocks(matrix%dbcsr)
182 : num_blocks = dbm_get_num_blocks(matrix)
183 : num_blocks_diff = ABS(num_blocks - num_blocks_dbcsr)
184 : IF (num_blocks_diff /= 0) THEN
185 : WRITE (*, *) "num_blocks mismatch dbcsr:", num_blocks_dbcsr, "new:", num_blocks
186 : IF (DBM_VALIDATE_NBLOCKS_MATCH) &
187 : CPABORT("num_blocks mismatch")
188 : END IF
189 :
190 : IF (DBM_VALIDATE_NBLOCKS_MATCH) THEN
191 : CPASSERT(dbm_get_nze(matrix) == dbcsr_get_nze(matrix%dbcsr))
192 : END IF
193 :
194 : ! check all dbcsr blocks
195 : norm2 = 0.0_dp
196 : CALL dbcsr_iterator_start(iter, matrix%dbcsr)
197 : DO WHILE (dbcsr_iterator_blocks_left(iter))
198 : CALL dbcsr_iterator_next_block(iter, row=row, column=col, block=block_dbcsr, &
199 : transposed=transposed, &
200 : row_size=row_size_dbcsr, col_size=col_size_dbcsr)
201 : CPASSERT(.NOT. transposed)
202 : CALL dbm_get_block_p_c(matrix=matrix%c_ptr, row=row - 1, col=col - 1, &
203 : block=block_c, row_size=row_size, col_size=col_size)
204 :
205 : CPASSERT(row_size == row_size_dbcsr .AND. col_size == col_size_dbcsr)
206 : IF (SIZE(block_dbcsr) == 0) THEN
207 : CYCLE
208 : END IF
209 : IF (.NOT. C_ASSOCIATED(block_c)) THEN
210 : CPASSERT(MAXVAL(ABS(block_dbcsr)) < DBM_VALIDATE_THRESHOLD)
211 : CYCLE
212 : END IF
213 :
214 : CALL C_F_POINTER(block_c, block, shape=(/row_size, col_size/))
215 : DO i = 1, row_size
216 : DO j = 1, col_size
217 : rel_diff = ABS(block(i, j) - block_dbcsr(i, j))/MAX(1.0_dp, ABS(block_dbcsr(i, j)))
218 : IF (rel_diff > DBM_VALIDATE_THRESHOLD) THEN
219 : WRITE (*, *) "row:", row, "col:", col, "i:", i, "j:", j, "rel_diff:", rel_diff
220 : WRITE (*, *) "values dbcsr:", block_dbcsr(i, j), "new:", block(i, j)
221 : CPABORT("block value mismatch")
222 : END IF
223 : END DO
224 : END DO
225 : norm2 = norm2 + SUM(block**2)
226 : block_dbcsr(:, :) = block(:, :) ! quench numerical noise
227 : END DO
228 : CALL dbcsr_iterator_stop(iter)
229 :
230 : ! Can not call dbcsr_get_block_p because it's INTENT(INOUT) :-(
231 :
232 : !! At least check that the norm (=checksum) of excesive blocks is small.
233 : !TODO: sum norm2 across all mpi ranks.
234 : !TODO: re-add INTERFACE to dbm_checksum_c, which got removed by prettify.
235 : !rel_diff = ABS(dbm_checksum_c(matrix%c_ptr) - norm2)/MAX(1.0_dp, norm2)
236 : !IF (rel_diff > DBM_VALIDATE_THRESHOLD) THEN
237 : ! WRITE (*, *) "num_blocks dbcsr:", num_blocks_dbcsr, "new:", num_blocks
238 : ! WRITE (*, *) "norm2: ", norm2
239 : ! WRITE (*, *) "relative residual norm diff: ", rel_diff
240 : ! CPABORT("residual norm diff")
241 : !END IF
242 : END SUBROUTINE validate
243 :
244 : #else
245 :
246 : ! **************************************************************************************************
247 : !> \brief Dummy for when DBM_VALIDATE_AGAINST_DBCSR is not defined.
248 : !> \param matrix ...
249 : ! **************************************************************************************************
250 0 : SUBROUTINE validate(matrix)
251 : TYPE(dbm_type), INTENT(IN) :: matrix
252 :
253 : MARK_USED(matrix)
254 0 : END SUBROUTINE validate
255 : #endif
256 :
257 : ! **************************************************************************************************
258 : !> \brief Creates a new matrix from given template, reusing dist and row/col_block_sizes.
259 : !> \param matrix ...
260 : !> \param name ...
261 : !> \param template ...
262 : !> \author Ole Schuett
263 : ! **************************************************************************************************
264 627229 : SUBROUTINE dbm_create_from_template(matrix, name, template)
265 : TYPE(dbm_type), INTENT(INOUT) :: matrix
266 : CHARACTER(len=*), INTENT(IN) :: name
267 : TYPE(dbm_type), INTENT(IN) :: template
268 :
269 627229 : INTEGER, CONTIGUOUS, DIMENSION(:), POINTER :: col_block_sizes, row_block_sizes
270 :
271 : ! Store pointers in intermediate variables to workaround a CCE error.
272 1254458 : row_block_sizes => dbm_get_row_block_sizes(template)
273 627229 : col_block_sizes => dbm_get_col_block_sizes(template)
274 :
275 : CALL dbm_create(matrix, &
276 : name=name, &
277 : dist=dbm_get_distribution(template), &
278 : row_block_sizes=row_block_sizes, &
279 627229 : col_block_sizes=col_block_sizes)
280 :
281 627229 : END SUBROUTINE dbm_create_from_template
282 :
283 : ! **************************************************************************************************
284 : !> \brief Creates a new matrix.
285 : !> \param matrix ...
286 : !> \param name ...
287 : !> \param dist ...
288 : !> \param row_block_sizes ...
289 : !> \param col_block_sizes ...
290 : !> \author Ole Schuett
291 : ! **************************************************************************************************
292 1097007 : SUBROUTINE dbm_create(matrix, name, dist, row_block_sizes, col_block_sizes)
293 : TYPE(dbm_type), INTENT(INOUT) :: matrix
294 : CHARACTER(len=*), INTENT(IN) :: name
295 : TYPE(dbm_distribution_obj), INTENT(IN) :: dist
296 : INTEGER, CONTIGUOUS, DIMENSION(:), INTENT(IN), &
297 : POINTER :: row_block_sizes, col_block_sizes
298 :
299 : INTERFACE
300 : SUBROUTINE dbm_create_c(matrix, dist, name, nrows, ncols, row_sizes, col_sizes) &
301 : BIND(C, name="dbm_create")
302 : IMPORT :: C_PTR, C_CHAR, C_INT
303 : TYPE(C_PTR) :: matrix
304 : TYPE(C_PTR), VALUE :: dist
305 : CHARACTER(kind=C_CHAR), DIMENSION(*) :: name
306 : INTEGER(kind=C_INT), VALUE :: nrows
307 : INTEGER(kind=C_INT), VALUE :: ncols
308 : INTEGER(kind=C_INT), DIMENSION(*) :: row_sizes
309 : INTEGER(kind=C_INT), DIMENSION(*) :: col_sizes
310 : END SUBROUTINE dbm_create_c
311 : END INTERFACE
312 :
313 1097007 : CPASSERT(.NOT. C_ASSOCIATED(matrix%c_ptr))
314 : CALL dbm_create_c(matrix=matrix%c_ptr, &
315 : dist=dist%c_ptr, &
316 : name=TRIM(name)//C_NULL_CHAR, &
317 : nrows=SIZE(row_block_sizes), &
318 : ncols=SIZE(col_block_sizes), &
319 : row_sizes=row_block_sizes, &
320 1097007 : col_sizes=col_block_sizes)
321 1097007 : CPASSERT(C_ASSOCIATED(matrix%c_ptr))
322 :
323 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
324 : CALL dbcsr_create(matrix%dbcsr, name=name, dist=dist%dbcsr, &
325 : matrix_type=dbcsr_type_no_symmetry, &
326 : row_blk_size=row_block_sizes, col_blk_size=col_block_sizes, &
327 : data_type=dbcsr_type_real_8)
328 :
329 : CALL validate(matrix)
330 : #endif
331 1097007 : END SUBROUTINE dbm_create
332 :
333 : ! **************************************************************************************************
334 : !> \brief Needed to be called for DBCSR after blocks where inserted. For DBM it's a no-opt.
335 : !> \param matrix ...
336 : !> \author Ole Schuett
337 : ! **************************************************************************************************
338 1796874 : SUBROUTINE dbm_finalize(matrix)
339 : TYPE(dbm_type), INTENT(INOUT) :: matrix
340 :
341 : MARK_USED(matrix) ! New implementation does not need finalize.
342 :
343 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
344 : CALL dbcsr_finalize(matrix%dbcsr)
345 : #endif
346 1796874 : END SUBROUTINE dbm_finalize
347 :
348 : ! **************************************************************************************************
349 : !> \brief Releases a matrix and all its ressources.
350 : !> \param matrix ...
351 : !> \author Ole Schuett
352 : ! **************************************************************************************************
353 1097007 : SUBROUTINE dbm_release(matrix)
354 : TYPE(dbm_type), INTENT(INOUT) :: matrix
355 :
356 : INTERFACE
357 : SUBROUTINE dbm_release_c(matrix) &
358 : BIND(C, name="dbm_release")
359 : IMPORT :: C_PTR
360 : TYPE(C_PTR), VALUE :: matrix
361 : END SUBROUTINE dbm_release_c
362 : END INTERFACE
363 :
364 1097007 : CALL dbm_release_c(matrix=matrix%c_ptr)
365 1097007 : matrix%c_ptr = C_NULL_PTR
366 :
367 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
368 : CALL dbcsr_release(matrix%dbcsr)
369 : #endif
370 1097007 : END SUBROUTINE dbm_release
371 :
372 : ! **************************************************************************************************
373 : !> \brief Copies content of matrix_b into matrix_a.
374 : !> Matrices must have the same row/col block sizes and distribution.
375 : !> \param matrix_a ...
376 : !> \param matrix_b ...
377 : !> \author Ole Schuett
378 : ! **************************************************************************************************
379 256044 : SUBROUTINE dbm_copy(matrix_a, matrix_b)
380 : TYPE(dbm_type), INTENT(INOUT) :: matrix_a
381 : TYPE(dbm_type), INTENT(IN) :: matrix_b
382 :
383 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_copy'
384 :
385 : INTEGER :: handle
386 : INTERFACE
387 : SUBROUTINE dbm_copy_c(matrix_a, matrix_b) &
388 : BIND(C, name="dbm_copy")
389 : IMPORT :: C_PTR
390 : TYPE(C_PTR), VALUE :: matrix_a
391 : TYPE(C_PTR), VALUE :: matrix_b
392 : END SUBROUTINE dbm_copy_c
393 : END INTERFACE
394 :
395 256044 : CALL timeset(routineN, handle)
396 256044 : CALL dbm_copy_c(matrix_a=matrix_a%c_ptr, matrix_b=matrix_b%c_ptr)
397 :
398 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
399 : CALL dbcsr_copy(matrix_a%dbcsr, matrix_b%dbcsr)
400 : CALL validate(matrix_a)
401 : #endif
402 256044 : CALL timestop(handle)
403 256044 : END SUBROUTINE dbm_copy
404 :
405 : ! **************************************************************************************************
406 : !> \brief Copies content of matrix_b into matrix_a. Matrices may have different distributions.
407 : !> \param matrix ...
408 : !> \param redist ...
409 : !> \author Ole Schuett
410 : ! **************************************************************************************************
411 144 : SUBROUTINE dbm_redistribute(matrix, redist)
412 : TYPE(dbm_type), INTENT(IN) :: matrix
413 : TYPE(dbm_type), INTENT(INOUT) :: redist
414 :
415 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_redistribute'
416 :
417 : INTEGER :: handle
418 : INTERFACE
419 : SUBROUTINE dbm_redistribute_c(matrix, redist) &
420 : BIND(C, name="dbm_redistribute")
421 : IMPORT :: C_PTR
422 : TYPE(C_PTR), VALUE :: matrix
423 : TYPE(C_PTR), VALUE :: redist
424 : END SUBROUTINE dbm_redistribute_c
425 : END INTERFACE
426 :
427 144 : CALL timeset(routineN, handle)
428 144 : CALL dbm_redistribute_c(matrix=matrix%c_ptr, redist=redist%c_ptr)
429 :
430 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
431 : CALL dbcsr_redistribute(matrix%dbcsr, redist%dbcsr)
432 : CALL validate(redist)
433 : #endif
434 144 : CALL timestop(handle)
435 144 : END SUBROUTINE dbm_redistribute
436 :
437 : ! **************************************************************************************************
438 : !> \brief Looks up a block from given matrics. This routine is thread-safe.
439 : !> If the block is not found then a null pointer is returned.
440 : !> \param matrix ...
441 : !> \param row ...
442 : !> \param col ...
443 : !> \param block ...
444 : !> \param row_size ...
445 : !> \param col_size ...
446 : !> \author Ole Schuett
447 : ! **************************************************************************************************
448 17482199 : SUBROUTINE dbm_get_block_p(matrix, row, col, block, row_size, col_size)
449 : TYPE(dbm_type), INTENT(INOUT) :: matrix
450 : INTEGER, INTENT(IN) :: row, col
451 : REAL(dp), DIMENSION(:, :), INTENT(OUT), POINTER :: block
452 : INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size
453 :
454 : INTEGER :: my_col_size, my_row_size
455 : TYPE(C_PTR) :: block_c
456 : INTERFACE
457 : SUBROUTINE dbm_get_block_p_c(matrix, row, col, block, row_size, col_size) &
458 : BIND(C, name="dbm_get_block_p")
459 : IMPORT :: C_PTR, C_INT
460 : TYPE(C_PTR), VALUE :: matrix
461 : INTEGER(kind=C_INT), VALUE :: row
462 : INTEGER(kind=C_INT), VALUE :: col
463 : TYPE(C_PTR) :: block
464 : INTEGER(kind=C_INT) :: row_size
465 : INTEGER(kind=C_INT) :: col_size
466 : END SUBROUTINE dbm_get_block_p_c
467 : END INTERFACE
468 :
469 : CALL dbm_get_block_p_c(matrix=matrix%c_ptr, row=row - 1, col=col - 1, &
470 17482199 : block=block_c, row_size=my_row_size, col_size=my_col_size)
471 17482199 : IF (C_ASSOCIATED(block_c)) THEN
472 48159582 : CALL C_F_POINTER(block_c, block, shape=(/my_row_size, my_col_size/))
473 : ELSE
474 1429005 : NULLIFY (block) ! block not found
475 : END IF
476 17482199 : IF (PRESENT(row_size)) row_size = my_row_size
477 17482199 : IF (PRESENT(col_size)) col_size = my_col_size
478 17482199 : END SUBROUTINE dbm_get_block_p
479 :
480 : ! **************************************************************************************************
481 : !> \brief Adds a block to given matrix. This routine is thread-safe.
482 : !> If block already exist then it gets overwritten (or summed).
483 : !> \param matrix ...
484 : !> \param row ...
485 : !> \param col ...
486 : !> \param block ...
487 : !> \param summation ...
488 : !> \author Ole Schuett
489 : ! **************************************************************************************************
490 27856431 : SUBROUTINE dbm_put_block(matrix, row, col, block, summation)
491 : TYPE(dbm_type), INTENT(INOUT) :: matrix
492 : INTEGER, INTENT(IN) :: row, col
493 : REAL(dp), CONTIGUOUS, DIMENSION(:, :), INTENT(IN) :: block
494 : LOGICAL, INTENT(IN), OPTIONAL :: summation
495 :
496 : LOGICAL :: my_summation
497 : INTERFACE
498 : SUBROUTINE dbm_put_block_c(matrix, row, col, summation, block) &
499 : BIND(C, name="dbm_put_block")
500 : IMPORT :: C_PTR, C_INT, C_BOOL, C_DOUBLE
501 : TYPE(C_PTR), VALUE :: matrix
502 : INTEGER(kind=C_INT), VALUE :: row
503 : INTEGER(kind=C_INT), VALUE :: col
504 : LOGICAL(kind=C_BOOL), VALUE :: summation
505 : REAL(kind=C_DOUBLE), DIMENSION(*) :: block
506 : END SUBROUTINE dbm_put_block_c
507 : END INTERFACE
508 :
509 27856431 : my_summation = .FALSE.
510 27856431 : IF (PRESENT(summation)) my_summation = summation
511 :
512 : CALL dbm_put_block_c(matrix=matrix%c_ptr, &
513 : row=row - 1, col=col - 1, &
514 : summation=LOGICAL(my_summation, C_BOOL), &
515 27856431 : block=block)
516 :
517 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
518 : CALL dbcsr_put_block(matrix%dbcsr, row, col, block, summation=summation)
519 : ! Can not call validate(matrix) because the dbcsr matrix needs to be finalized first.
520 : #endif
521 27856431 : END SUBROUTINE dbm_put_block
522 :
523 : ! **************************************************************************************************
524 : !> \brief Remove all blocks from given matrix, but does not release the underlying memory.
525 : !> \param matrix ...
526 : !> \author Ole Schuett
527 : ! **************************************************************************************************
528 1395048 : SUBROUTINE dbm_clear(matrix)
529 : TYPE(dbm_type), INTENT(INOUT) :: matrix
530 :
531 : INTERFACE
532 : SUBROUTINE dbm_clear_c(matrix) &
533 : BIND(C, name="dbm_clear")
534 : IMPORT :: C_PTR
535 : TYPE(C_PTR), VALUE :: matrix
536 : END SUBROUTINE dbm_clear_c
537 : END INTERFACE
538 :
539 1395048 : CALL dbm_clear_c(matrix=matrix%c_ptr)
540 :
541 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
542 : CALL dbcsr_clear(matrix%dbcsr)
543 : CALL validate(matrix)
544 : #endif
545 1395048 : END SUBROUTINE dbm_clear
546 :
547 : ! **************************************************************************************************
548 : !> \brief Removes all blocks from the given matrix whose block norm is below the given threshold.
549 : !> Blocks of size zero are always kept.
550 : !> \param matrix ...
551 : !> \param eps ...
552 : !> \author Ole Schuett
553 : ! **************************************************************************************************
554 300290 : SUBROUTINE dbm_filter(matrix, eps)
555 : TYPE(dbm_type), INTENT(INOUT) :: matrix
556 : REAL(dp), INTENT(IN) :: eps
557 :
558 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_filter'
559 :
560 : INTEGER :: handle
561 : INTERFACE
562 : SUBROUTINE dbm_filter_c(matrix, eps) &
563 : BIND(C, name="dbm_filter")
564 : IMPORT :: C_PTR, C_DOUBLE
565 : TYPE(C_PTR), VALUE :: matrix
566 : REAL(kind=C_DOUBLE), VALUE :: eps
567 : END SUBROUTINE dbm_filter_c
568 : END INTERFACE
569 :
570 300290 : CALL timeset(routineN, handle)
571 : CALL validate(matrix)
572 300290 : CALL dbm_filter_c(matrix=matrix%c_ptr, eps=eps)
573 :
574 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
575 : CALL dbcsr_filter(matrix%dbcsr, eps)
576 : CALL validate(matrix)
577 : #endif
578 300290 : CALL timestop(handle)
579 300290 : END SUBROUTINE dbm_filter
580 :
581 : ! **************************************************************************************************
582 : !> \brief Adds given list of blocks efficiently. The blocks will be filled with zeros.
583 : !> \param matrix ...
584 : !> \param rows ...
585 : !> \param cols ...
586 : !> \author Ole Schuett
587 : ! **************************************************************************************************
588 1045521 : SUBROUTINE dbm_reserve_blocks(matrix, rows, cols)
589 : TYPE(dbm_type), INTENT(INOUT) :: matrix
590 : INTEGER, DIMENSION(:), INTENT(IN) :: rows, cols
591 :
592 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_reserve_blocks'
593 :
594 : INTEGER :: handle
595 2091042 : INTEGER(kind=C_INT), DIMENSION(SIZE(rows)) :: cols_c, rows_c
596 : INTERFACE
597 : SUBROUTINE dbm_reserve_blocks_c(matrix, nblocks, rows, cols) &
598 : BIND(C, name="dbm_reserve_blocks")
599 : IMPORT :: C_PTR, C_INT
600 : TYPE(C_PTR), VALUE :: matrix
601 : INTEGER(kind=C_INT), VALUE :: nblocks
602 : INTEGER(kind=C_INT), DIMENSION(*) :: rows
603 : INTEGER(kind=C_INT), DIMENSION(*) :: cols
604 : END SUBROUTINE dbm_reserve_blocks_c
605 : END INTERFACE
606 :
607 1045521 : CALL timeset(routineN, handle)
608 1045521 : CPASSERT(SIZE(rows) == SIZE(cols))
609 24327930 : rows_c = rows - 1
610 24327930 : cols_c = cols - 1
611 :
612 : CALL dbm_reserve_blocks_c(matrix=matrix%c_ptr, &
613 : nblocks=SIZE(rows), &
614 : rows=rows_c, &
615 1045521 : cols=cols_c)
616 :
617 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
618 : CALL dbcsr_reserve_blocks(matrix%dbcsr, rows, cols)
619 : CALL validate(matrix)
620 : #endif
621 1045521 : CALL timestop(handle)
622 1045521 : END SUBROUTINE dbm_reserve_blocks
623 :
624 : ! **************************************************************************************************
625 : !> \brief Multiplies all entries in the given matrix by the given factor alpha.
626 : !> \param matrix ...
627 : !> \param alpha ...
628 : !> \author Ole Schuett
629 : ! **************************************************************************************************
630 135916 : SUBROUTINE dbm_scale(matrix, alpha)
631 : TYPE(dbm_type), INTENT(INOUT) :: matrix
632 : REAL(dp), INTENT(IN) :: alpha
633 :
634 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_scale'
635 :
636 : INTEGER :: handle
637 : INTERFACE
638 : SUBROUTINE dbm_scale_c(matrix, alpha) &
639 : BIND(C, name="dbm_scale")
640 : IMPORT :: C_PTR, C_DOUBLE
641 : TYPE(C_PTR), VALUE :: matrix
642 : REAL(kind=C_DOUBLE), VALUE :: alpha
643 : END SUBROUTINE dbm_scale_c
644 : END INTERFACE
645 :
646 135916 : CALL timeset(routineN, handle)
647 135916 : CALL dbm_scale_c(matrix=matrix%c_ptr, alpha=alpha)
648 :
649 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
650 : CALL dbcsr_scale(matrix%dbcsr, alpha)
651 : CALL validate(matrix)
652 : #endif
653 135916 : CALL timestop(handle)
654 135916 : END SUBROUTINE dbm_scale
655 :
656 : ! **************************************************************************************************
657 : !> \brief Sets all blocks in the given matrix to zero.
658 : !> \param matrix ...
659 : !> \author Ole Schuett
660 : ! **************************************************************************************************
661 0 : SUBROUTINE dbm_zero(matrix)
662 : TYPE(dbm_type), INTENT(INOUT) :: matrix
663 :
664 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_zero'
665 :
666 : INTEGER :: handle
667 : INTERFACE
668 : SUBROUTINE dbm_zero_c(matrix) &
669 : BIND(C, name="dbm_zero")
670 : IMPORT :: C_PTR
671 : TYPE(C_PTR), VALUE :: matrix
672 : END SUBROUTINE dbm_zero_c
673 : END INTERFACE
674 :
675 0 : CALL timeset(routineN, handle)
676 0 : CALL dbm_zero_c(matrix=matrix%c_ptr)
677 :
678 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
679 : CALL dbcsr_zero(matrix%dbcsr)
680 : CALL validate(matrix)
681 : #endif
682 0 : CALL timestop(handle)
683 0 : END SUBROUTINE dbm_zero
684 :
685 : ! **************************************************************************************************
686 : !> \brief Adds matrix_b to matrix_a.
687 : !> \param matrix_a ...
688 : !> \param matrix_b ...
689 : !> \author Ole Schuett
690 : ! **************************************************************************************************
691 125667 : SUBROUTINE dbm_add(matrix_a, matrix_b)
692 : TYPE(dbm_type), INTENT(INOUT) :: matrix_a
693 : TYPE(dbm_type), INTENT(IN) :: matrix_b
694 :
695 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_add'
696 :
697 : INTEGER :: handle
698 : INTERFACE
699 : SUBROUTINE dbm_add_c(matrix_a, matrix_b) &
700 : BIND(C, name="dbm_add")
701 : IMPORT :: C_PTR, C_DOUBLE
702 : TYPE(C_PTR), VALUE :: matrix_a
703 : TYPE(C_PTR), VALUE :: matrix_b
704 : END SUBROUTINE dbm_add_c
705 : END INTERFACE
706 :
707 125667 : CALL timeset(routineN, handle)
708 : CALL validate(matrix_a)
709 : CALL validate(matrix_b)
710 125667 : CALL dbm_add_c(matrix_a=matrix_a%c_ptr, matrix_b=matrix_b%c_ptr)
711 :
712 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
713 : CALL dbcsr_add(matrix_a%dbcsr, matrix_b%dbcsr)
714 : CALL validate(matrix_a)
715 : #endif
716 125667 : CALL timestop(handle)
717 125667 : END SUBROUTINE dbm_add
718 :
719 : ! **************************************************************************************************
720 : !> \brief Computes matrix product: matrix_c = alpha * matrix_a * matrix_b + beta * matrix_c.
721 : !> \param transa ...
722 : !> \param transb ...
723 : !> \param alpha ...
724 : !> \param matrix_a ...
725 : !> \param matrix_b ...
726 : !> \param beta ...
727 : !> \param matrix_c ...
728 : !> \param retain_sparsity ...
729 : !> \param filter_eps ...
730 : !> \param flop ...
731 : !> \author Ole Schuett
732 : ! **************************************************************************************************
733 125697 : SUBROUTINE dbm_multiply(transa, transb, &
734 : alpha, matrix_a, matrix_b, beta, matrix_c, &
735 : retain_sparsity, filter_eps, flop)
736 : LOGICAL, INTENT(IN) :: transa, transb
737 : REAL(kind=dp), INTENT(IN) :: alpha
738 : TYPE(dbm_type), INTENT(IN) :: matrix_a, matrix_b
739 : REAL(kind=dp), INTENT(IN) :: beta
740 : TYPE(dbm_type), INTENT(INOUT) :: matrix_c
741 : LOGICAL, INTENT(IN), OPTIONAL :: retain_sparsity
742 : REAL(kind=dp), INTENT(IN), OPTIONAL :: filter_eps
743 : INTEGER(int_8), INTENT(OUT), OPTIONAL :: flop
744 :
745 : CHARACTER(LEN=*), PARAMETER :: routineN = 'dbm_multiply'
746 :
747 : CHARACTER(LEN=1) :: transa_char, transb_char
748 : INTEGER :: handle
749 : INTEGER(int_8) :: flop_dbcsr, my_flop
750 : LOGICAL :: my_retain_sparsity
751 : REAL(kind=dp) :: my_filter_eps
752 : INTERFACE
753 : SUBROUTINE dbm_multiply_c(transa, transb, alpha, &
754 : matrix_a, matrix_b, &
755 : beta, matrix_c, &
756 : retain_sparsity, filter_eps, flop) &
757 : BIND(C, name="dbm_multiply")
758 : IMPORT :: C_PTR, C_DOUBLE, C_BOOL, C_INT64_T
759 : LOGICAL(kind=C_BOOL), VALUE :: transa
760 : LOGICAL(kind=C_BOOL), VALUE :: transb
761 : REAL(kind=C_DOUBLE), VALUE :: alpha
762 : TYPE(C_PTR), VALUE :: matrix_a
763 : TYPE(C_PTR), VALUE :: matrix_b
764 : REAL(kind=C_DOUBLE), VALUE :: beta
765 : TYPE(C_PTR), VALUE :: matrix_c
766 : LOGICAL(kind=C_BOOL), VALUE :: retain_sparsity
767 : REAL(kind=C_DOUBLE), VALUE :: filter_eps
768 : INTEGER(kind=C_INT64_T) :: flop
769 : END SUBROUTINE dbm_multiply_c
770 : END INTERFACE
771 :
772 125697 : CALL timeset(routineN, handle)
773 :
774 125697 : IF (PRESENT(retain_sparsity)) THEN
775 4792 : my_retain_sparsity = retain_sparsity
776 : ELSE
777 : my_retain_sparsity = .FALSE.
778 : END IF
779 :
780 125697 : IF (PRESENT(filter_eps)) THEN
781 125671 : my_filter_eps = filter_eps
782 : ELSE
783 : my_filter_eps = 0.0_dp
784 : END IF
785 :
786 : CALL validate(matrix_a)
787 : CALL validate(matrix_b)
788 : CALL validate(matrix_c)
789 : CALL dbm_multiply_c(transa=LOGICAL(transa, C_BOOL), &
790 : transb=LOGICAL(transb, C_BOOL), &
791 : alpha=alpha, &
792 : matrix_a=matrix_a%c_ptr, &
793 : matrix_b=matrix_b%c_ptr, &
794 : beta=beta, &
795 : matrix_c=matrix_c%c_ptr, &
796 : retain_sparsity=LOGICAL(my_retain_sparsity, C_BOOL), &
797 : filter_eps=my_filter_eps, &
798 125697 : flop=my_flop)
799 :
800 125697 : IF (PRESENT(flop)) THEN
801 90675 : flop = my_flop
802 : END IF
803 :
804 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
805 : IF (transa) THEN
806 : transa_char = dbcsr_transpose
807 : ELSE
808 : transa_char = dbcsr_no_transpose
809 : END IF
810 : IF (transb) THEN
811 : transb_char = dbcsr_transpose
812 : ELSE
813 : transb_char = dbcsr_no_transpose
814 : END IF
815 : CALL dbcsr_multiply(transa=transa_char, transb=transb_char, &
816 : alpha=alpha, matrix_a=matrix_a%dbcsr, &
817 : matrix_b=matrix_b%dbcsr, beta=beta, matrix_c=matrix_c%dbcsr, &
818 : retain_sparsity=retain_sparsity, filter_eps=filter_eps, flop=flop_dbcsr)
819 : CPASSERT(my_flop == flop_dbcsr)
820 : CALL validate(matrix_c)
821 : #else
822 : ! Can not use preprocessor's ifdefs before INTERFACE because it confuses prettify.
823 : MARK_USED(transa_char)
824 : MARK_USED(transb_char)
825 : MARK_USED(flop_dbcsr)
826 : #endif
827 125697 : CALL timestop(handle)
828 125697 : END SUBROUTINE dbm_multiply
829 :
830 : ! **************************************************************************************************
831 : !> \brief Creates an iterator for the blocks of the given matrix. The iteration order is not stable.
832 : !> \param iterator ...
833 : !> \param matrix ...
834 : !> \author Ole Schuett
835 : ! **************************************************************************************************
836 2486837 : SUBROUTINE dbm_iterator_start(iterator, matrix)
837 : TYPE(dbm_iterator), INTENT(OUT) :: iterator
838 : TYPE(dbm_type), INTENT(IN) :: matrix
839 :
840 : INTERFACE
841 : SUBROUTINE dbm_iterator_start_c(iterator, matrix) &
842 : BIND(C, name="dbm_iterator_start")
843 : IMPORT :: C_PTR
844 : TYPE(C_PTR) :: iterator
845 : TYPE(C_PTR), VALUE :: matrix
846 : END SUBROUTINE dbm_iterator_start_c
847 : END INTERFACE
848 :
849 : CPASSERT(.NOT. C_ASSOCIATED(iterator%c_ptr))
850 2486837 : CALL dbm_iterator_start_c(iterator=iterator%c_ptr, matrix=matrix%c_ptr)
851 2486837 : CPASSERT(C_ASSOCIATED(iterator%c_ptr))
852 : CALL validate(matrix)
853 2486837 : END SUBROUTINE dbm_iterator_start
854 :
855 : ! **************************************************************************************************
856 : !> \brief Returns number of blocks the iterator will provide to calling thread.
857 : !> \param iterator ...
858 : !> \return ...
859 : !> \author Ole Schuett
860 : ! **************************************************************************************************
861 491958 : FUNCTION dbm_iterator_num_blocks(iterator) RESULT(num_blocks)
862 : TYPE(dbm_iterator), INTENT(IN) :: iterator
863 : INTEGER :: num_blocks
864 :
865 : INTERFACE
866 : FUNCTION dbm_iterator_num_blocks_c(iterator) &
867 : BIND(C, name="dbm_iterator_num_blocks")
868 : IMPORT :: C_PTR, C_INT
869 : TYPE(C_PTR), VALUE :: iterator
870 : INTEGER(kind=C_INT) :: dbm_iterator_num_blocks_c
871 : END FUNCTION dbm_iterator_num_blocks_c
872 : END INTERFACE
873 :
874 491958 : num_blocks = dbm_iterator_num_blocks_c(iterator%c_ptr)
875 491958 : END FUNCTION dbm_iterator_num_blocks
876 :
877 : ! **************************************************************************************************
878 : !> \brief Tests whether the given iterator has any block left.
879 : !> \param iterator ...
880 : !> \return ...
881 : !> \author Ole Schuett
882 : ! **************************************************************************************************
883 46564361 : FUNCTION dbm_iterator_blocks_left(iterator) RESULT(blocks_left)
884 : TYPE(dbm_iterator), INTENT(IN) :: iterator
885 : LOGICAL :: blocks_left
886 :
887 : INTERFACE
888 : FUNCTION dbm_iterator_blocks_left_c(iterator) &
889 : BIND(C, name="dbm_iterator_blocks_left")
890 : IMPORT :: C_PTR, C_BOOL
891 : TYPE(C_PTR), VALUE :: iterator
892 : LOGICAL(C_BOOL) :: dbm_iterator_blocks_left_c
893 : END FUNCTION dbm_iterator_blocks_left_c
894 : END INTERFACE
895 :
896 46564361 : blocks_left = dbm_iterator_blocks_left_c(iterator%c_ptr)
897 46564361 : END FUNCTION dbm_iterator_blocks_left
898 :
899 : ! **************************************************************************************************
900 : !> \brief Returns the next block from the given iterator.
901 : !> \param iterator ...
902 : !> \param row ...
903 : !> \param column ...
904 : !> \param block ...
905 : !> \param row_size ...
906 : !> \param col_size ...
907 : !> \author Ole Schuett
908 : ! **************************************************************************************************
909 52132688 : SUBROUTINE dbm_iterator_next_block(iterator, row, column, block, row_size, col_size)
910 : TYPE(dbm_iterator), INTENT(INOUT) :: iterator
911 : INTEGER, INTENT(OUT) :: row, column
912 : REAL(dp), DIMENSION(:, :), INTENT(OUT), OPTIONAL, &
913 : POINTER :: block
914 : INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size
915 :
916 : INTEGER :: col0, my_col_size, my_row_size, row0
917 : TYPE(C_PTR) :: block_c
918 : INTERFACE
919 : SUBROUTINE dbm_iterator_next_block_c(iterator, row, col, block, row_size, col_size) &
920 : BIND(C, name="dbm_iterator_next_block")
921 : IMPORT :: C_PTR, C_INT
922 : TYPE(C_PTR), VALUE :: iterator
923 : INTEGER(kind=C_INT) :: row
924 : INTEGER(kind=C_INT) :: col
925 : TYPE(C_PTR) :: block
926 : INTEGER(kind=C_INT) :: row_size
927 : INTEGER(kind=C_INT) :: col_size
928 : END SUBROUTINE dbm_iterator_next_block_c
929 : END INTERFACE
930 :
931 : CALL dbm_iterator_next_block_c(iterator%c_ptr, row=row0, col=col0, block=block_c, &
932 52132688 : row_size=my_row_size, col_size=my_col_size)
933 :
934 52132688 : CPASSERT(C_ASSOCIATED(block_c))
935 75120752 : IF (PRESENT(block)) CALL C_F_POINTER(block_c, block, shape=(/my_row_size, my_col_size/))
936 52132688 : row = row0 + 1
937 52132688 : column = col0 + 1
938 52132688 : IF (PRESENT(row_size)) row_size = my_row_size
939 52132688 : IF (PRESENT(col_size)) col_size = my_col_size
940 52132688 : END SUBROUTINE dbm_iterator_next_block
941 :
942 : ! **************************************************************************************************
943 : !> \brief Releases the given iterator.
944 : !> \param iterator ...
945 : !> \author Ole Schuett
946 : ! **************************************************************************************************
947 2486837 : SUBROUTINE dbm_iterator_stop(iterator)
948 : TYPE(dbm_iterator), INTENT(INOUT) :: iterator
949 :
950 : INTERFACE
951 : SUBROUTINE dbm_iterator_stop_c(iterator) &
952 : BIND(C, name="dbm_iterator_stop")
953 : IMPORT :: C_PTR
954 : TYPE(C_PTR), VALUE :: iterator
955 : END SUBROUTINE dbm_iterator_stop_c
956 : END INTERFACE
957 :
958 2486837 : CALL dbm_iterator_stop_c(iterator%c_ptr)
959 2486837 : iterator%c_ptr = C_NULL_PTR
960 2486837 : END SUBROUTINE dbm_iterator_stop
961 :
962 : ! **************************************************************************************************
963 : !> \brief Computes a checksum of the given matrix.
964 : !> \param matrix ...
965 : !> \return ...
966 : !> \author Ole Schuett
967 : ! **************************************************************************************************
968 190 : FUNCTION dbm_checksum(matrix) RESULT(res)
969 : TYPE(dbm_type), INTENT(IN) :: matrix
970 : REAL(KIND=dp) :: res
971 :
972 : INTERFACE
973 : FUNCTION dbm_checksum_c(matrix) &
974 : BIND(C, name="dbm_checksum")
975 : IMPORT :: C_PTR, C_DOUBLE
976 : TYPE(C_PTR), VALUE :: matrix
977 : REAL(C_DOUBLE) :: dbm_checksum_c
978 : END FUNCTION dbm_checksum_c
979 : END INTERFACE
980 :
981 : CALL validate(matrix)
982 190 : res = dbm_checksum_c(matrix%c_ptr)
983 :
984 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
985 : CPASSERT(ABS(res - dbcsr_checksum(matrix%dbcsr))/MAX(1.0_dp, ABS(res)) < DBM_VALIDATE_THRESHOLD)
986 : #endif
987 190 : END FUNCTION dbm_checksum
988 :
989 : ! **************************************************************************************************
990 : !> \brief Returns the absolute value of the larges element of the entire given matrix.
991 : !> \param matrix ...
992 : !> \return ...
993 : !> \author Ole Schuett
994 : ! **************************************************************************************************
995 48 : FUNCTION dbm_maxabs(matrix) RESULT(res)
996 : TYPE(dbm_type), INTENT(INOUT) :: matrix
997 : REAL(KIND=dp) :: res
998 :
999 : INTERFACE
1000 : FUNCTION dbm_maxabs_c(matrix) &
1001 : BIND(C, name="dbm_maxabs")
1002 : IMPORT :: C_PTR, C_DOUBLE
1003 : TYPE(C_PTR), VALUE :: matrix
1004 : REAL(C_DOUBLE) :: dbm_maxabs_c
1005 : END FUNCTION dbm_maxabs_c
1006 : END INTERFACE
1007 :
1008 : CALL validate(matrix)
1009 48 : res = dbm_maxabs_c(matrix%c_ptr)
1010 :
1011 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1012 : CPASSERT(ABS(res - dbcsr_maxabs(matrix%dbcsr))/MAX(1.0_dp, ABS(res)) < DBM_VALIDATE_THRESHOLD)
1013 : #endif
1014 48 : END FUNCTION dbm_maxabs
1015 :
1016 : ! **************************************************************************************************
1017 : !> \brief Returns the name of the matrix of the given matrix.
1018 : !> \param matrix ...
1019 : !> \return ...
1020 : !> \author Ole Schuett
1021 : ! **************************************************************************************************
1022 1086610 : FUNCTION dbm_get_name(matrix) RESULT(res)
1023 : TYPE(dbm_type), INTENT(IN) :: matrix
1024 : CHARACTER(len=default_string_length) :: res
1025 :
1026 : CHARACTER(LEN=1, KIND=C_CHAR), DIMENSION(:), &
1027 1086610 : POINTER :: name_f
1028 : INTEGER :: i
1029 : TYPE(C_PTR) :: name_c
1030 : INTERFACE
1031 : FUNCTION dbm_get_name_c(matrix) BIND(C, name="dbm_get_name")
1032 : IMPORT :: C_PTR
1033 : TYPE(C_PTR), VALUE :: matrix
1034 : TYPE(C_PTR) :: dbm_get_name_c
1035 : END FUNCTION dbm_get_name_c
1036 : END INTERFACE
1037 :
1038 1086610 : name_c = dbm_get_name_c(matrix%c_ptr)
1039 :
1040 2173220 : CALL C_F_POINTER(name_c, name_f, shape=(/default_string_length/))
1041 :
1042 1086610 : res = ""
1043 22679145 : DO i = 1, default_string_length
1044 22679145 : IF (name_f(i) == C_NULL_CHAR) EXIT
1045 22679145 : res(i:i) = name_f(i)
1046 : END DO
1047 :
1048 1086610 : END FUNCTION dbm_get_name
1049 :
1050 : ! **************************************************************************************************
1051 : !> \brief Returns the number of local Non-Zero Elements of the given matrix.
1052 : !> \param matrix ...
1053 : !> \return ...
1054 : !> \author Ole Schuett
1055 : ! **************************************************************************************************
1056 1322990 : PURE FUNCTION dbm_get_nze(matrix) RESULT(res)
1057 : TYPE(dbm_type), INTENT(IN) :: matrix
1058 : INTEGER :: res
1059 :
1060 : INTERFACE
1061 : PURE FUNCTION dbm_get_nze_c(matrix) &
1062 : BIND(C, name="dbm_get_nze")
1063 : IMPORT :: C_PTR, C_INT
1064 : TYPE(C_PTR), VALUE, INTENT(IN) :: matrix
1065 : INTEGER(C_INT) :: dbm_get_nze_c
1066 : END FUNCTION dbm_get_nze_c
1067 : END INTERFACE
1068 :
1069 1322990 : res = dbm_get_nze_c(matrix%c_ptr)
1070 :
1071 1322990 : END FUNCTION dbm_get_nze
1072 :
1073 : ! **************************************************************************************************
1074 : !> \brief Returns the number of local blocks of the given matrix.
1075 : !> \param matrix ...
1076 : !> \return ...
1077 : !> \author Ole Schuett
1078 : ! **************************************************************************************************
1079 825008 : PURE FUNCTION dbm_get_num_blocks(matrix) RESULT(res)
1080 : TYPE(dbm_type), INTENT(IN) :: matrix
1081 : INTEGER :: res
1082 :
1083 : INTERFACE
1084 : PURE FUNCTION dbm_get_num_blocks_c(matrix) &
1085 : BIND(C, name="dbm_get_num_blocks")
1086 : IMPORT :: C_PTR, C_INT
1087 : TYPE(C_PTR), VALUE, INTENT(IN) :: matrix
1088 : INTEGER(C_INT) :: dbm_get_num_blocks_c
1089 : END FUNCTION dbm_get_num_blocks_c
1090 : END INTERFACE
1091 :
1092 825008 : res = dbm_get_num_blocks_c(matrix%c_ptr)
1093 :
1094 825008 : END FUNCTION dbm_get_num_blocks
1095 :
1096 : ! **************************************************************************************************
1097 : !> \brief Returns the row block sizes of the given matrix.
1098 : !> \param matrix ...
1099 : !> \return ...
1100 : !> \author Ole Schuett
1101 : ! **************************************************************************************************
1102 3688572 : FUNCTION dbm_get_row_block_sizes(matrix) RESULT(res)
1103 : TYPE(dbm_type), INTENT(IN) :: matrix
1104 : INTEGER, CONTIGUOUS, DIMENSION(:), POINTER :: res
1105 :
1106 : INTEGER :: nrows
1107 : TYPE(C_PTR) :: row_sizes
1108 : INTERFACE
1109 : SUBROUTINE dbm_get_row_sizes_c(matrix, nrows, row_sizes) &
1110 : BIND(C, name="dbm_get_row_sizes")
1111 : IMPORT :: C_PTR, C_INT
1112 : TYPE(C_PTR), VALUE :: matrix
1113 : INTEGER(C_INT) :: nrows
1114 : TYPE(C_PTR) :: row_sizes
1115 : END SUBROUTINE dbm_get_row_sizes_c
1116 : END INTERFACE
1117 :
1118 3688572 : CALL dbm_get_row_sizes_c(matrix%c_ptr, nrows, row_sizes)
1119 7377144 : CALL C_F_POINTER(row_sizes, res, shape=(/nrows/))
1120 : ! TODO: maybe return an ALLOCATABLE
1121 3688572 : END FUNCTION dbm_get_row_block_sizes
1122 :
1123 : ! **************************************************************************************************
1124 : !> \brief Returns the column block sizes of the given matrix.
1125 : !> \param matrix ...
1126 : !> \return ...
1127 : !> \author Ole Schuett
1128 : ! **************************************************************************************************
1129 2831352 : FUNCTION dbm_get_col_block_sizes(matrix) RESULT(res)
1130 : TYPE(dbm_type), INTENT(IN) :: matrix
1131 : INTEGER, CONTIGUOUS, DIMENSION(:), POINTER :: res
1132 :
1133 : INTEGER :: ncols
1134 : TYPE(C_PTR) :: col_sizes
1135 : INTERFACE
1136 : SUBROUTINE dbm_get_col_sizes_c(matrix, ncols, col_sizes) &
1137 : BIND(C, name="dbm_get_col_sizes")
1138 : IMPORT :: C_PTR, C_INT
1139 : TYPE(C_PTR), VALUE :: matrix
1140 : INTEGER(C_INT) :: ncols
1141 : TYPE(C_PTR) :: col_sizes
1142 : END SUBROUTINE dbm_get_col_sizes_c
1143 : END INTERFACE
1144 :
1145 2831352 : CALL dbm_get_col_sizes_c(matrix%c_ptr, ncols, col_sizes)
1146 5662704 : CALL C_F_POINTER(col_sizes, res, shape=(/ncols/))
1147 : ! TODO: maybe return an ALLOCATABLE
1148 2831352 : END FUNCTION dbm_get_col_block_sizes
1149 :
1150 : ! **************************************************************************************************
1151 : !> \brief Returns the local row block sizes of the given matrix.
1152 : !> \param matrix ...
1153 : !> \param local_rows ...
1154 : !> \return ...
1155 : !> \author Ole Schuett
1156 : ! **************************************************************************************************
1157 163452 : SUBROUTINE dbm_get_local_rows(matrix, local_rows)
1158 : TYPE(dbm_type), INTENT(IN) :: matrix
1159 : INTEGER, ALLOCATABLE, DIMENSION(:) :: local_rows
1160 :
1161 : INTEGER :: nlocal_rows
1162 163452 : INTEGER, DIMENSION(:), POINTER :: local_rows_dbcsr, local_rows_ptr
1163 : TYPE(C_PTR) :: local_rows_c
1164 : INTERFACE
1165 : SUBROUTINE dbm_get_local_rows_c(matrix, nlocal_rows, local_rows) &
1166 : BIND(C, name="dbm_get_local_rows")
1167 : IMPORT :: C_PTR, C_INT
1168 : TYPE(C_PTR), VALUE :: matrix
1169 : INTEGER(C_INT) :: nlocal_rows
1170 : TYPE(C_PTR) :: local_rows
1171 : END SUBROUTINE dbm_get_local_rows_c
1172 : END INTERFACE
1173 :
1174 163452 : CALL dbm_get_local_rows_c(matrix%c_ptr, nlocal_rows, local_rows_c)
1175 326904 : CALL C_F_POINTER(local_rows_c, local_rows_ptr, shape=(/nlocal_rows/))
1176 490332 : ALLOCATE (local_rows(nlocal_rows))
1177 2881796 : local_rows(:) = local_rows_ptr(:) + 1
1178 :
1179 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1180 : CALL dbcsr_get_info(matrix%dbcsr, local_rows=local_rows_dbcsr)
1181 : CPASSERT(ALL(local_rows == local_rows_dbcsr))
1182 : #else
1183 : MARK_USED(local_rows_dbcsr)
1184 : #endif
1185 163452 : END SUBROUTINE dbm_get_local_rows
1186 :
1187 : ! **************************************************************************************************
1188 : !> \brief Returns the local column block sizes of the given matrix.
1189 : !> \param matrix ...
1190 : !> \param local_cols ...
1191 : !> \return ...
1192 : !> \author Ole Schuett
1193 : ! **************************************************************************************************
1194 73518 : SUBROUTINE dbm_get_local_cols(matrix, local_cols)
1195 : TYPE(dbm_type), INTENT(IN) :: matrix
1196 : INTEGER, ALLOCATABLE, DIMENSION(:) :: local_cols
1197 :
1198 : INTEGER :: nlocal_cols
1199 73518 : INTEGER, DIMENSION(:), POINTER :: local_cols_dbcsr, local_cols_ptr
1200 : TYPE(C_PTR) :: local_cols_c
1201 : INTERFACE
1202 : SUBROUTINE dbm_get_local_cols_c(matrix, nlocal_cols, local_cols) &
1203 : BIND(C, name="dbm_get_local_cols")
1204 : IMPORT :: C_PTR, C_INT
1205 : TYPE(C_PTR), VALUE :: matrix
1206 : INTEGER(C_INT) :: nlocal_cols
1207 : TYPE(C_PTR) :: local_cols
1208 : END SUBROUTINE dbm_get_local_cols_c
1209 : END INTERFACE
1210 :
1211 73518 : CALL dbm_get_local_cols_c(matrix%c_ptr, nlocal_cols, local_cols_c)
1212 147036 : CALL C_F_POINTER(local_cols_c, local_cols_ptr, shape=(/nlocal_cols/))
1213 217430 : ALLOCATE (local_cols(nlocal_cols))
1214 38400552 : local_cols(:) = local_cols_ptr(:) + 1
1215 :
1216 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1217 : CALL dbcsr_get_info(matrix%dbcsr, local_cols=local_cols_dbcsr)
1218 : CPASSERT(ALL(local_cols == local_cols_dbcsr))
1219 : #else
1220 : MARK_USED(local_cols_dbcsr)
1221 : #endif
1222 73518 : END SUBROUTINE dbm_get_local_cols
1223 :
1224 : ! **************************************************************************************************
1225 : !> \brief Returns the MPI rank on which the given block should be stored.
1226 : !> \param matrix ...
1227 : !> \param row ...
1228 : !> \param column ...
1229 : !> \param processor ...
1230 : !> \author Ole Schuett
1231 : ! **************************************************************************************************
1232 2057680 : SUBROUTINE dbm_get_stored_coordinates(matrix, row, column, processor)
1233 : TYPE(dbm_type), INTENT(IN) :: matrix
1234 : INTEGER, INTENT(IN) :: row, column
1235 : INTEGER, INTENT(OUT) :: processor
1236 :
1237 : INTEGER :: processor_dbcsr
1238 : INTERFACE
1239 : PURE FUNCTION dbm_get_stored_coordinates_c(matrix, row, col) &
1240 : BIND(C, name="dbm_get_stored_coordinates")
1241 : IMPORT :: C_PTR, C_INT
1242 : TYPE(C_PTR), VALUE, INTENT(IN) :: matrix
1243 : INTEGER(C_INT), VALUE, INTENT(IN) :: row
1244 : INTEGER(C_INT), VALUE, INTENT(IN) :: col
1245 : INTEGER(C_INT) :: dbm_get_stored_coordinates_c
1246 : END FUNCTION dbm_get_stored_coordinates_c
1247 : END INTERFACE
1248 :
1249 2057680 : processor = dbm_get_stored_coordinates_c(matrix%c_ptr, row=row - 1, col=column - 1)
1250 :
1251 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1252 : CALL dbcsr_get_stored_coordinates(matrix%dbcsr, row, column, processor_dbcsr)
1253 : CPASSERT(processor == processor_dbcsr)
1254 : #else
1255 : MARK_USED(processor_dbcsr)
1256 : #endif
1257 2057680 : END SUBROUTINE dbm_get_stored_coordinates
1258 :
1259 : ! **************************************************************************************************
1260 : !> \brief Returns the distribution of the given matrix.
1261 : !> \param matrix ...
1262 : !> \return ...
1263 : !> \author Ole Schuett
1264 : ! **************************************************************************************************
1265 868777 : FUNCTION dbm_get_distribution(matrix) RESULT(res)
1266 : TYPE(dbm_type), INTENT(IN) :: matrix
1267 : TYPE(dbm_distribution_obj) :: res
1268 :
1269 : INTERFACE
1270 : FUNCTION dbm_get_distribution_c(matrix) BIND(C, name="dbm_get_distribution")
1271 : IMPORT :: C_PTR
1272 : TYPE(C_PTR), VALUE :: matrix
1273 : TYPE(C_PTR) :: dbm_get_distribution_c
1274 : END FUNCTION dbm_get_distribution_c
1275 : END INTERFACE
1276 :
1277 1737554 : res%c_ptr = dbm_get_distribution_c(matrix%c_ptr)
1278 :
1279 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1280 : CALL dbcsr_get_info(matrix%dbcsr, distribution=res%dbcsr)
1281 : #endif
1282 :
1283 868777 : END FUNCTION dbm_get_distribution
1284 :
1285 : ! **************************************************************************************************
1286 : !> \brief Creates a new two dimensional distribution.
1287 : !> \param dist ...
1288 : !> \param mp_comm ...
1289 : !> \param row_dist_block ...
1290 : !> \param col_dist_block ...
1291 : !> \author Ole Schuett
1292 : ! **************************************************************************************************
1293 589740 : SUBROUTINE dbm_distribution_new(dist, mp_comm, row_dist_block, col_dist_block)
1294 : TYPE(dbm_distribution_obj), INTENT(OUT) :: dist
1295 :
1296 : CLASS(mp_comm_type), INTENT(IN) :: mp_comm
1297 : INTEGER, CONTIGUOUS, DIMENSION(:), INTENT(IN), &
1298 : POINTER :: row_dist_block, col_dist_block
1299 :
1300 : INTERFACE
1301 : SUBROUTINE dbm_distribution_new_c(dist, fortran_comm, nrows, ncols, row_dist, col_dist) &
1302 : BIND(C, name="dbm_distribution_new")
1303 : IMPORT :: C_PTR, C_CHAR, C_INT
1304 : TYPE(C_PTR) :: dist
1305 : INTEGER(kind=C_INT), VALUE :: fortran_comm
1306 : INTEGER(kind=C_INT), VALUE :: nrows
1307 : INTEGER(kind=C_INT), VALUE :: ncols
1308 : INTEGER(kind=C_INT), DIMENSION(*) :: row_dist
1309 : INTEGER(kind=C_INT), DIMENSION(*) :: col_dist
1310 : END SUBROUTINE dbm_distribution_new_c
1311 : END INTERFACE
1312 :
1313 : CPASSERT(.NOT. C_ASSOCIATED(dist%c_ptr))
1314 : CALL dbm_distribution_new_c(dist=dist%c_ptr, &
1315 : fortran_comm=mp_comm%get_handle(), &
1316 : nrows=SIZE(row_dist_block), &
1317 : ncols=SIZE(col_dist_block), &
1318 : row_dist=row_dist_block, &
1319 589740 : col_dist=col_dist_block)
1320 589740 : CPASSERT(C_ASSOCIATED(dist%c_ptr))
1321 :
1322 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1323 : CALL dbcsr_distribution_new_wrapper(dist, mp_comm, row_dist_block, col_dist_block)
1324 : #endif
1325 589740 : END SUBROUTINE dbm_distribution_new
1326 :
1327 : ! **************************************************************************************************
1328 : !> \brief Helper for creating a new DBCSR distribution. Only needed for DBM_VALIDATE_AGAINST_DBCSR.
1329 : !> \param dist ...
1330 : !> \param mp_comm ...
1331 : !> \param row_dist_block ...
1332 : !> \param col_dist_block ...
1333 : !> \author Ole Schuett
1334 : ! **************************************************************************************************
1335 0 : SUBROUTINE dbcsr_distribution_new_wrapper(dist, mp_comm, row_dist_block, col_dist_block)
1336 : TYPE(dbm_distribution_obj), INTENT(INOUT) :: dist
1337 : TYPE(mp_cart_type), INTENT(IN) :: mp_comm
1338 : INTEGER, CONTIGUOUS, DIMENSION(:), INTENT(IN), &
1339 : POINTER :: row_dist_block, col_dist_block
1340 :
1341 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1342 : INTEGER :: mynode, numnodes, pcol, prow
1343 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: pgrid
1344 : INTEGER, DIMENSION(2) :: coord, mycoord, npdims
1345 : TYPE(dbcsr_mp_obj) :: mp_env
1346 :
1347 : ! Create a dbcsr mp environment from communicator
1348 : CALL mp_comm%get_info_cart(npdims, mycoord)
1349 : CALL mp_comm%get_size(numnodes)
1350 : CALL mp_comm%get_rank(mynode)
1351 : ALLOCATE (pgrid(0:npdims(1) - 1, 0:npdims(2) - 1))
1352 : DO prow = 0, npdims(1) - 1
1353 : DO pcol = 0, npdims(2) - 1
1354 : coord = (/prow, pcol/)
1355 : CALL mp_comm%rank_cart(coord, pgrid(prow, pcol))
1356 : END DO
1357 : END DO
1358 : CPASSERT(mynode == pgrid(mycoord(1), mycoord(2)))
1359 :
1360 : CALL dbcsr_mp_new(mp_env, mp_comm%get_handle(), pgrid, mynode, numnodes, mycoord(1), mycoord(2))
1361 : CALL dbcsr_distribution_new(dist=dist%dbcsr, mp_env=mp_env, &
1362 : row_dist_block=row_dist_block, col_dist_block=col_dist_block)
1363 : CALL dbcsr_mp_release(mp_env)
1364 : #else
1365 : MARK_USED(dist)
1366 : MARK_USED(mp_comm)
1367 : MARK_USED(row_dist_block)
1368 : MARK_USED(col_dist_block)
1369 : #endif
1370 0 : END SUBROUTINE dbcsr_distribution_new_wrapper
1371 :
1372 : ! **************************************************************************************************
1373 : !> \brief Increases the reference counter of the given distribution.
1374 : !> \param dist ...
1375 : !> \author Ole Schuett
1376 : ! **************************************************************************************************
1377 501460 : SUBROUTINE dbm_distribution_hold(dist)
1378 : TYPE(dbm_distribution_obj) :: dist
1379 :
1380 : INTERFACE
1381 : SUBROUTINE dbm_distribution_hold_c(dist) &
1382 : BIND(C, name="dbm_distribution_hold")
1383 : IMPORT :: C_PTR
1384 : TYPE(C_PTR), VALUE :: dist
1385 : END SUBROUTINE dbm_distribution_hold_c
1386 : END INTERFACE
1387 :
1388 501460 : CALL dbm_distribution_hold_c(dist%c_ptr)
1389 :
1390 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1391 : CALL dbcsr_distribution_hold(dist%dbcsr)
1392 : #endif
1393 501460 : END SUBROUTINE dbm_distribution_hold
1394 :
1395 : ! **************************************************************************************************
1396 : !> \brief Decreases the reference counter of the given distribution.
1397 : !> \param dist ...
1398 : !> \author Ole Schuett
1399 : ! **************************************************************************************************
1400 1091200 : SUBROUTINE dbm_distribution_release(dist)
1401 : TYPE(dbm_distribution_obj) :: dist
1402 :
1403 : INTERFACE
1404 : SUBROUTINE dbm_distribution_release_c(dist) &
1405 : BIND(C, name="dbm_distribution_release")
1406 : IMPORT :: C_PTR
1407 : TYPE(C_PTR), VALUE :: dist
1408 : END SUBROUTINE dbm_distribution_release_c
1409 : END INTERFACE
1410 :
1411 1091200 : CALL dbm_distribution_release_c(dist%c_ptr)
1412 :
1413 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1414 : CALL dbcsr_distribution_release(dist%dbcsr)
1415 : #endif
1416 1091200 : END SUBROUTINE dbm_distribution_release
1417 :
1418 : ! **************************************************************************************************
1419 : !> \brief Returns the rows of the given distribution.
1420 : !> \param dist ...
1421 : !> \return ...
1422 : !> \author Ole Schuett
1423 : ! **************************************************************************************************
1424 241548 : FUNCTION dbm_distribution_row_dist(dist) RESULT(res)
1425 : TYPE(dbm_distribution_obj), INTENT(IN) :: dist
1426 : INTEGER, CONTIGUOUS, DIMENSION(:), POINTER :: res
1427 :
1428 : INTEGER :: nrows
1429 : TYPE(C_PTR) :: row_dist
1430 : INTERFACE
1431 : SUBROUTINE dbm_distribution_row_dist_c(dist, nrows, row_dist) &
1432 : BIND(C, name="dbm_distribution_row_dist")
1433 : IMPORT :: C_PTR, C_INT
1434 : TYPE(C_PTR), VALUE :: dist
1435 : INTEGER(C_INT) :: nrows
1436 : TYPE(C_PTR) :: row_dist
1437 : END SUBROUTINE dbm_distribution_row_dist_c
1438 : END INTERFACE
1439 :
1440 241548 : CALL dbm_distribution_row_dist_c(dist%c_ptr, nrows, row_dist)
1441 483096 : CALL C_F_POINTER(row_dist, res, shape=(/nrows/))
1442 :
1443 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1444 : CPASSERT(ALL(res == dbcsr_distribution_row_dist(dist%dbcsr)))
1445 : #endif
1446 241548 : END FUNCTION dbm_distribution_row_dist
1447 :
1448 : ! **************************************************************************************************
1449 : !> \brief Returns the columns of the given distribution.
1450 : !> \param dist ...
1451 : !> \return ...
1452 : !> \author Ole Schuett
1453 : ! **************************************************************************************************
1454 241548 : FUNCTION dbm_distribution_col_dist(dist) RESULT(res)
1455 : TYPE(dbm_distribution_obj), INTENT(IN) :: dist
1456 : INTEGER, CONTIGUOUS, DIMENSION(:), POINTER :: res
1457 :
1458 : INTEGER :: ncols
1459 : TYPE(C_PTR) :: col_dist
1460 : INTERFACE
1461 : SUBROUTINE dbm_distribution_col_dist_c(dist, ncols, col_dist) &
1462 : BIND(C, name="dbm_distribution_col_dist")
1463 : IMPORT :: C_PTR, C_INT
1464 : TYPE(C_PTR), VALUE :: dist
1465 : INTEGER(C_INT) :: ncols
1466 : TYPE(C_PTR) :: col_dist
1467 : END SUBROUTINE dbm_distribution_col_dist_c
1468 : END INTERFACE
1469 :
1470 241548 : CALL dbm_distribution_col_dist_c(dist%c_ptr, ncols, col_dist)
1471 483096 : CALL C_F_POINTER(col_dist, res, shape=(/ncols/))
1472 :
1473 : #if defined(DBM_VALIDATE_AGAINST_DBCSR)
1474 : CPASSERT(ALL(res == dbcsr_distribution_col_dist(dist%dbcsr)))
1475 : #endif
1476 241548 : END FUNCTION dbm_distribution_col_dist
1477 :
1478 : ! **************************************************************************************************
1479 : !> \brief Initialize DBM library
1480 : !> \author Ole Schuett
1481 : ! **************************************************************************************************
1482 8396 : SUBROUTINE dbm_library_init()
1483 : INTERFACE
1484 : SUBROUTINE dbm_library_init_c() BIND(C, name="dbm_library_init")
1485 : END SUBROUTINE dbm_library_init_c
1486 : END INTERFACE
1487 :
1488 8396 : CALL dbm_library_init_c()
1489 :
1490 8396 : END SUBROUTINE dbm_library_init
1491 :
1492 : ! **************************************************************************************************
1493 : !> \brief Finalize DBM library
1494 : !> \author Ole Schuett
1495 : ! **************************************************************************************************
1496 8396 : SUBROUTINE dbm_library_finalize()
1497 : INTERFACE
1498 : SUBROUTINE dbm_library_finalize_c() BIND(C, name="dbm_library_finalize")
1499 : END SUBROUTINE dbm_library_finalize_c
1500 : END INTERFACE
1501 :
1502 8396 : CALL dbm_library_finalize_c()
1503 :
1504 8396 : END SUBROUTINE dbm_library_finalize
1505 :
1506 : ! **************************************************************************************************
1507 : !> \brief Print DBM library statistics
1508 : !> \param mpi_comm ...
1509 : !> \param output_unit ...
1510 : !> \author Ole Schuett
1511 : ! **************************************************************************************************
1512 8514 : SUBROUTINE dbm_library_print_stats(mpi_comm, output_unit)
1513 : TYPE(mp_comm_type), INTENT(IN) :: mpi_comm
1514 : INTEGER, INTENT(IN) :: output_unit
1515 :
1516 : INTERFACE
1517 : SUBROUTINE dbm_library_print_stats_c(mpi_comm, print_func, output_unit) &
1518 : BIND(C, name="dbm_library_print_stats")
1519 : IMPORT :: C_FUNPTR, C_INT
1520 : INTEGER(KIND=C_INT), VALUE :: mpi_comm
1521 : TYPE(C_FUNPTR), VALUE :: print_func
1522 : INTEGER(KIND=C_INT), VALUE :: output_unit
1523 : END SUBROUTINE dbm_library_print_stats_c
1524 : END INTERFACE
1525 :
1526 : ! Since Fortran units groups can't be used from C, we pass a function pointer instead.
1527 : CALL dbm_library_print_stats_c(mpi_comm=mpi_comm%get_handle(), &
1528 : print_func=C_FUNLOC(print_func), &
1529 8514 : output_unit=output_unit)
1530 :
1531 8514 : END SUBROUTINE dbm_library_print_stats
1532 :
1533 : ! **************************************************************************************************
1534 : !> \brief Callback to write to a Fortran output unit.
1535 : !> \param message ...
1536 : !> \param output_unit ...
1537 : !> \author Ole Schuett
1538 : ! **************************************************************************************************
1539 70538 : SUBROUTINE print_func(message, output_unit) BIND(C, name="dbm_api_print_func")
1540 : CHARACTER(LEN=1, KIND=C_CHAR), INTENT(IN) :: message(*)
1541 : INTEGER(KIND=C_INT), INTENT(IN), VALUE :: output_unit
1542 :
1543 : CHARACTER(LEN=1000) :: buffer
1544 : INTEGER :: nchars
1545 :
1546 70538 : IF (output_unit <= 0) &
1547 35045 : RETURN
1548 :
1549 : ! Convert C char array into Fortran string.
1550 35493 : nchars = strlcpy_c2f(buffer, message)
1551 :
1552 : ! Print the message.
1553 35493 : WRITE (output_unit, FMT="(A)", ADVANCE="NO") buffer(1:nchars)
1554 : END SUBROUTINE print_func
1555 :
1556 0 : END MODULE dbm_api
|
