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