(git:31876b5)
Loading...
Searching...
No Matches
cp_dbcsr_operations.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief DBCSR operations in CP2K
10!> \author Urban Borstnik
11!> \date 2009-05-12
12!> \version 0.8
13!>
14!> <b>Modification history:</b>
15!> - Created 2009-05-12
16!> - Generalized sm_fm_mulitply for matrices w/ different row/col block size (A. Bussy, 11.2018)
17! **************************************************************************************************
18MODULE cp_dbcsr_operations
19 USE cp_blacs_env, ONLY: cp_blacs_env_type
20 USE cp_dbcsr_api, ONLY: &
21 dbcsr_add, dbcsr_complete_redistribute, dbcsr_convert_sizes_to_offsets, dbcsr_copy, &
22 dbcsr_create, dbcsr_deallocate_matrix, dbcsr_desymmetrize, dbcsr_distribution_get, &
23 dbcsr_distribution_new, dbcsr_distribution_release, dbcsr_distribution_type, &
24 dbcsr_get_info, dbcsr_get_matrix_type, dbcsr_iterator_blocks_left, &
25 dbcsr_iterator_next_block, dbcsr_iterator_readonly_start, dbcsr_iterator_start, &
26 dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_multiply, dbcsr_p_type, dbcsr_release, &
27 dbcsr_scale, dbcsr_type, dbcsr_type_antisymmetric, dbcsr_type_no_symmetry, &
28 dbcsr_type_symmetric, dbcsr_valid_index, dbcsr_verify_matrix
29 USE cp_dbcsr_contrib, ONLY: dbcsr_frobenius_norm,&
30 dbcsr_reserve_all_blocks
31 USE cp_fm_basic_linalg, ONLY: cp_fm_gemm
32 USE cp_fm_struct, ONLY: cp_fm_struct_create,&
33 cp_fm_struct_release,&
34 cp_fm_struct_type
35 USE cp_fm_types, ONLY: cp_fm_create,&
36 cp_fm_get_info,&
37 cp_fm_release,&
38 cp_fm_to_fm,&
39 cp_fm_type
40 USE distribution_2d_types, ONLY: distribution_2d_get,&
41 distribution_2d_type
42 USE kinds, ONLY: default_string_length,&
43 dp
44 USE mathlib, ONLY: gcd,&
45 lcm
46 USE message_passing, ONLY: mp_para_env_type
47
48!$ USE OMP_LIB, ONLY: omp_get_max_threads, omp_get_thread_num, omp_get_num_threads
49#include "base/base_uses.f90"
50
51 IMPLICIT NONE
52 PRIVATE
53
54 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_dbcsr_operations'
55 LOGICAL, PARAMETER :: debug_mod = .false.
56
57 INTEGER, SAVE, PUBLIC :: max_elements_per_block = 32
58
59 PUBLIC :: dbcsr_multiply_local
60
61 ! CP2K API emulation
62 PUBLIC :: copy_fm_to_dbcsr, copy_dbcsr_to_fm, &
63 cp_dbcsr_sm_fm_multiply, cp_dbcsr_plus_fm_fm_t, &
64 copy_dbcsr_to_fm_bc, copy_fm_to_dbcsr_bc, cp_fm_to_dbcsr_row_template, &
65 cp_dbcsr_m_by_n_from_template, cp_dbcsr_m_by_n_from_row_template, &
66 dbcsr_create_dist_r_unrot
67
68 ! distribution_2d_type compatibility
69 PUBLIC :: cp_dbcsr_dist2d_to_dist
70
71 PUBLIC :: dbcsr_copy_columns_hack
72
73 ! matrix set
74 PUBLIC :: dbcsr_allocate_matrix_set
75 PUBLIC :: dbcsr_deallocate_matrix_set
76
77 INTERFACE dbcsr_allocate_matrix_set
78 MODULE PROCEDURE allocate_dbcsr_matrix_set_1d
79 MODULE PROCEDURE allocate_dbcsr_matrix_set_2d
80 MODULE PROCEDURE allocate_dbcsr_matrix_set_3d
81 MODULE PROCEDURE allocate_dbcsr_matrix_set_4d
82 MODULE PROCEDURE allocate_dbcsr_matrix_set_5d
83 END INTERFACE
84
85 INTERFACE dbcsr_deallocate_matrix_set
86 MODULE PROCEDURE deallocate_dbcsr_matrix_set_1d
87 MODULE PROCEDURE deallocate_dbcsr_matrix_set_2d
88 MODULE PROCEDURE deallocate_dbcsr_matrix_set_3d
89 MODULE PROCEDURE deallocate_dbcsr_matrix_set_4d
90 MODULE PROCEDURE deallocate_dbcsr_matrix_set_5d
91 END INTERFACE
92
93CONTAINS
94
95! **************************************************************************************************
96!> \brief Copy a BLACS matrix to a dbcsr matrix.
97!>
98!> real_matrix=beta*real_matrix+alpha*fm
99!> beta defaults to 0, alpha to 1
100!> \param[in] fm full matrix
101!> \param[out] matrix DBCSR matrix
102!> \param[in] keep_sparsity (optional) retains the sparsity of the input
103!> matrix
104!> \date 2009-10-13
105!> \par History
106!> 2009-10-13 rewritten based on copy_dbcsr_to_fm
107!> \author Urban Borstnik
108!> \version 2.0
109! **************************************************************************************************
110 SUBROUTINE copy_fm_to_dbcsr(fm, matrix, keep_sparsity)
111 TYPE(cp_fm_type), INTENT(IN) :: fm
112 TYPE(dbcsr_type), INTENT(INOUT) :: matrix
113 LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity
114
115 CHARACTER(LEN=*), PARAMETER :: routinen = 'copy_fm_to_dbcsr'
116
117 INTEGER :: handle
118 LOGICAL :: my_keep_sparsity
119 TYPE(dbcsr_type) :: bc_mat, redist_mat
120
121 CALL timeset(routinen, handle)
122
123 my_keep_sparsity = .false.
124 IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity
125
126 CALL copy_fm_to_dbcsr_bc(fm, bc_mat)
127
128 IF (my_keep_sparsity) THEN
129 CALL dbcsr_create(redist_mat, template=matrix)
130 CALL dbcsr_complete_redistribute(bc_mat, redist_mat)
131 CALL dbcsr_copy(matrix, redist_mat, keep_sparsity=.true.)
132 CALL dbcsr_release(redist_mat)
133 ELSE
134 CALL dbcsr_complete_redistribute(bc_mat, matrix)
135 END IF
136
137 CALL dbcsr_release(bc_mat)
138
139 CALL timestop(handle)
140 END SUBROUTINE copy_fm_to_dbcsr
141
142! **************************************************************************************************
143!> \brief Copy a BLACS matrix to a dbcsr matrix with a special block-cyclic distribution,
144!> which requires no complete redistribution.
145!> \param fm ...
146!> \param bc_mat ...
147! **************************************************************************************************
148 SUBROUTINE copy_fm_to_dbcsr_bc(fm, bc_mat)
149 TYPE(cp_fm_type), INTENT(IN) :: fm
150 TYPE(dbcsr_type), INTENT(INOUT) :: bc_mat
151
152 CHARACTER(LEN=*), PARAMETER :: routinen = 'copy_fm_to_dbcsr_bc'
153
154 INTEGER :: col, handle, ncol_block, ncol_global, &
155 nrow_block, nrow_global, row
156 INTEGER, ALLOCATABLE, DIMENSION(:) :: first_col, first_row, last_col, last_row
157 INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size
158 INTEGER, DIMENSION(:, :), POINTER :: pgrid
159 REAL(kind=dp), DIMENSION(:, :), POINTER :: dbcsr_block, fm_block
160 TYPE(dbcsr_distribution_type) :: bc_dist
161 TYPE(dbcsr_iterator_type) :: iter
162
163 CALL timeset(routinen, handle)
164
165 ! Create processor grid
166 pgrid => fm%matrix_struct%context%blacs2mpi
167
168 ! Create a block-cyclic distribution compatible with the FM matrix.
169 nrow_block = fm%matrix_struct%nrow_block
170 ncol_block = fm%matrix_struct%ncol_block
171 nrow_global = fm%matrix_struct%nrow_global
172 ncol_global = fm%matrix_struct%ncol_global
173 NULLIFY (col_blk_size, row_blk_size)
174 CALL dbcsr_create_dist_block_cyclic(bc_dist, &
175 nrows=nrow_global, ncolumns=ncol_global, & ! Actual full matrix size
176 nrow_block=nrow_block, ncol_block=ncol_block, & ! BLACS parameters
177 group_handle=fm%matrix_struct%para_env%get_handle(), pgrid=pgrid, &
178 row_blk_sizes=row_blk_size, col_blk_sizes=col_blk_size) ! block-cyclic row/col sizes
179
180 ! Create the block-cyclic DBCSR matrix
181 CALL dbcsr_create(bc_mat, "Block-cyclic ", bc_dist, &
182 dbcsr_type_no_symmetry, row_blk_size, col_blk_size, reuse_arrays=.true.)
183 CALL dbcsr_distribution_release(bc_dist)
184
185 ! allocate all blocks
186 CALL dbcsr_reserve_all_blocks(bc_mat)
187
188 CALL calculate_fm_block_ranges(bc_mat, first_row, last_row, first_col, last_col)
189
190 ! Copy the FM data to the block-cyclic DBCSR matrix. This step
191 ! could be skipped with appropriate DBCSR index manipulation.
192 fm_block => fm%local_data
193!$OMP PARALLEL DEFAULT(NONE) PRIVATE(iter, row, col, dbcsr_block) &
194!$OMP SHARED(bc_mat, last_row, first_row, last_col, first_col, fm_block)
195 CALL dbcsr_iterator_start(iter, bc_mat)
196 DO WHILE (dbcsr_iterator_blocks_left(iter))
197 CALL dbcsr_iterator_next_block(iter, row, col, dbcsr_block)
198 dbcsr_block(:, :) = fm_block(first_row(row):last_row(row), first_col(col):last_col(col))
199 END DO
200 CALL dbcsr_iterator_stop(iter)
201!$OMP END PARALLEL
202
203 CALL timestop(handle)
204 END SUBROUTINE copy_fm_to_dbcsr_bc
205
206! **************************************************************************************************
207!> \brief Copy a DBCSR matrix to a BLACS matrix
208!> \param[in] matrix DBCSR matrix
209!> \param[out] fm full matrix
210! **************************************************************************************************
211 SUBROUTINE copy_dbcsr_to_fm(matrix, fm)
212 TYPE(dbcsr_type), INTENT(IN) :: matrix
213 TYPE(cp_fm_type), INTENT(INOUT) :: fm
214
215 CHARACTER(LEN=*), PARAMETER :: routinen = 'copy_dbcsr_to_fm'
216
217 CHARACTER(len=default_string_length) :: name
218 INTEGER :: group_handle, handle, ncol_block, &
219 nfullcols_total, nfullrows_total, &
220 nrow_block
221 INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size
222 INTEGER, DIMENSION(:, :), POINTER :: pgrid
223 TYPE(dbcsr_distribution_type) :: bc_dist, dist
224 TYPE(dbcsr_type) :: bc_mat, matrix_nosym
225
226 CALL timeset(routinen, handle)
227
228 ! check compatibility
229 CALL dbcsr_get_info(matrix, &
230 name=name, &
231 distribution=dist, &
232 nfullrows_total=nfullrows_total, &
233 nfullcols_total=nfullcols_total)
234
235 cpassert(fm%matrix_struct%nrow_global == nfullrows_total)
236 cpassert(fm%matrix_struct%ncol_global == nfullcols_total)
237
238 ! info about the full matrix
239 nrow_block = fm%matrix_struct%nrow_block
240 ncol_block = fm%matrix_struct%ncol_block
241
242 ! Convert DBCSR to a block-cyclic
243 NULLIFY (col_blk_size, row_blk_size)
244 CALL dbcsr_distribution_get(dist, group=group_handle, pgrid=pgrid)
245 CALL dbcsr_create_dist_block_cyclic(bc_dist, &
246 nrows=nfullrows_total, ncolumns=nfullcols_total, &
247 nrow_block=nrow_block, ncol_block=ncol_block, &
248 group_handle=group_handle, pgrid=pgrid, &
249 row_blk_sizes=row_blk_size, col_blk_sizes=col_blk_size)
250
251 CALL dbcsr_create(bc_mat, "Block-cyclic"//name, bc_dist, &
252 dbcsr_type_no_symmetry, row_blk_size, col_blk_size, reuse_arrays=.true.)
253 CALL dbcsr_distribution_release(bc_dist)
254
255 CALL dbcsr_create(matrix_nosym, template=matrix, matrix_type="N")
256 CALL dbcsr_desymmetrize(matrix, matrix_nosym)
257 CALL dbcsr_complete_redistribute(matrix_nosym, bc_mat)
258 CALL dbcsr_release(matrix_nosym)
259
260 CALL copy_dbcsr_to_fm_bc(bc_mat, fm)
261
262 CALL dbcsr_release(bc_mat)
263
264 CALL timestop(handle)
265 END SUBROUTINE copy_dbcsr_to_fm
266
267! **************************************************************************************************
268!> \brief Copy a DBCSR_BLACS matrix to a BLACS matrix
269!> \param bc_mat DBCSR matrix
270!> \param[out] fm full matrix
271! **************************************************************************************************
272 SUBROUTINE copy_dbcsr_to_fm_bc(bc_mat, fm)
273 TYPE(dbcsr_type), INTENT(IN) :: bc_mat
274 TYPE(cp_fm_type), INTENT(INOUT) :: fm
275
276 CHARACTER(LEN=*), PARAMETER :: routinen = 'copy_dbcsr_to_fm_bc'
277
278 INTEGER :: col, handle, row
279 INTEGER, ALLOCATABLE, DIMENSION(:) :: first_col, first_row, last_col, last_row
280 REAL(kind=dp), DIMENSION(:, :), POINTER :: dbcsr_block, fm_block
281 TYPE(dbcsr_iterator_type) :: iter
282
283 CALL timeset(routinen, handle)
284
285 CALL calculate_fm_block_ranges(bc_mat, first_row, last_row, first_col, last_col)
286
287 ! Now copy data to the FM matrix
288 fm_block => fm%local_data
289 fm_block = real(0.0, kind=dp)
290!$OMP PARALLEL DEFAULT(NONE) PRIVATE(iter, row, col, dbcsr_block) &
291!$OMP SHARED(bc_mat, last_row, first_row, last_col, first_col, fm_block)
292 CALL dbcsr_iterator_readonly_start(iter, bc_mat)
293 DO WHILE (dbcsr_iterator_blocks_left(iter))
294 CALL dbcsr_iterator_next_block(iter, row, col, dbcsr_block)
295 fm_block(first_row(row):last_row(row), first_col(col):last_col(col)) = dbcsr_block(:, :)
296 END DO
297 CALL dbcsr_iterator_stop(iter)
298!$OMP END PARALLEL
299
300 CALL timestop(handle)
301 END SUBROUTINE copy_dbcsr_to_fm_bc
302
303! **************************************************************************************************
304!> \brief Helper routine used to copy blocks from DBCSR into FM matrices and vice versa
305!> \param bc_mat ...
306!> \param first_row ...
307!> \param last_row ...
308!> \param first_col ...
309!> \param last_col ...
310!> \author Ole Schuett
311! **************************************************************************************************
312 SUBROUTINE calculate_fm_block_ranges(bc_mat, first_row, last_row, first_col, last_col)
313 TYPE(dbcsr_type), INTENT(IN) :: bc_mat
314 INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: first_row, last_row, first_col, last_col
315
316 INTEGER :: col, nblkcols_local, nblkcols_total, &
317 nblkrows_local, nblkrows_total, row
318 INTEGER, ALLOCATABLE, DIMENSION(:) :: local_col_sizes, local_row_sizes
319 INTEGER, DIMENSION(:), POINTER :: col_blk_size, local_cols, local_rows, &
320 row_blk_size
321
322 CALL dbcsr_get_info(bc_mat, &
323 nblkrows_total=nblkrows_total, &
324 nblkcols_total=nblkcols_total, &
325 nblkrows_local=nblkrows_local, &
326 nblkcols_local=nblkcols_local, &
327 local_rows=local_rows, &
328 local_cols=local_cols, &
329 row_blk_size=row_blk_size, &
330 col_blk_size=col_blk_size)
331
332 ! calculate first_row and last_row
333 ALLOCATE (local_row_sizes(nblkrows_total))
334 local_row_sizes(:) = 0
335 IF (nblkrows_local >= 1) THEN
336 DO row = 1, nblkrows_local
337 local_row_sizes(local_rows(row)) = row_blk_size(local_rows(row))
338 END DO
339 END IF
340 ALLOCATE (first_row(nblkrows_total), last_row(nblkrows_total))
341 CALL dbcsr_convert_sizes_to_offsets(local_row_sizes, first_row, last_row)
342 DEALLOCATE (local_row_sizes)
343
344 ! calculate first_col and last_col
345 ALLOCATE (local_col_sizes(nblkcols_total))
346 local_col_sizes(:) = 0
347 IF (nblkcols_local >= 1) THEN
348 DO col = 1, nblkcols_local
349 local_col_sizes(local_cols(col)) = col_blk_size(local_cols(col))
350 END DO
351 END IF
352 ALLOCATE (first_col(nblkcols_total), last_col(nblkcols_total))
353 CALL dbcsr_convert_sizes_to_offsets(local_col_sizes, first_col, last_col)
354 DEALLOCATE (local_col_sizes)
355
356 END SUBROUTINE calculate_fm_block_ranges
357
358! **************************************************************************************************
359!> \brief hack for dbcsr_copy_columns
360!> \param matrix_b ...
361!> \param matrix_a ...
362!> \param ncol ...
363!> \param source_start ...
364!> \param target_start ...
365!> \param para_env ...
366!> \param blacs_env ...
367!> \author vw
368! **************************************************************************************************
369 SUBROUTINE dbcsr_copy_columns_hack(matrix_b, matrix_a, &
370 ncol, source_start, target_start, para_env, blacs_env)
371
372 TYPE(dbcsr_type), INTENT(INOUT) :: matrix_b
373 TYPE(dbcsr_type), INTENT(IN) :: matrix_a
374 INTEGER, INTENT(IN) :: ncol, source_start, target_start
375 TYPE(mp_para_env_type), POINTER :: para_env
376 TYPE(cp_blacs_env_type), POINTER :: blacs_env
377
378 INTEGER :: nfullcols_total, nfullrows_total
379 TYPE(cp_fm_struct_type), POINTER :: fm_struct
380 TYPE(cp_fm_type) :: fm_matrix_a, fm_matrix_b
381
382 NULLIFY (fm_struct)
383 CALL dbcsr_get_info(matrix_a, nfullrows_total=nfullrows_total, nfullcols_total=nfullcols_total)
384 CALL cp_fm_struct_create(fm_struct, context=blacs_env, nrow_global=nfullrows_total, &
385 ncol_global=nfullcols_total, para_env=para_env)
386 CALL cp_fm_create(fm_matrix_a, fm_struct, name="fm_matrix_a")
387 CALL cp_fm_struct_release(fm_struct)
388
389 CALL dbcsr_get_info(matrix_b, nfullrows_total=nfullrows_total, nfullcols_total=nfullcols_total)
390 CALL cp_fm_struct_create(fm_struct, context=blacs_env, nrow_global=nfullrows_total, &
391 ncol_global=nfullcols_total, para_env=para_env)
392 CALL cp_fm_create(fm_matrix_b, fm_struct, name="fm_matrix_b")
393 CALL cp_fm_struct_release(fm_struct)
394
395 CALL copy_dbcsr_to_fm(matrix_a, fm_matrix_a)
396 CALL copy_dbcsr_to_fm(matrix_b, fm_matrix_b)
397
398 CALL cp_fm_to_fm(fm_matrix_a, fm_matrix_b, ncol, source_start, target_start)
399
400 CALL copy_fm_to_dbcsr(fm_matrix_b, matrix_b)
401
402 CALL cp_fm_release(fm_matrix_a)
403 CALL cp_fm_release(fm_matrix_b)
404
405 END SUBROUTINE dbcsr_copy_columns_hack
406
407! **************************************************************************************************
408!> \brief Creates a DBCSR distribution from a distribution_2d
409!> \param[in] dist2d distribution_2d
410!> \param[out] dist DBCSR distribution
411!> \par History
412!> move form dbcsr_operation 01.2010
413! **************************************************************************************************
414 SUBROUTINE cp_dbcsr_dist2d_to_dist(dist2d, dist)
415 TYPE(distribution_2d_type), INTENT(IN), TARGET :: dist2d
416 TYPE(dbcsr_distribution_type), INTENT(OUT) :: dist
417
418 INTEGER, DIMENSION(:), POINTER :: col_dist, row_dist
419 INTEGER, DIMENSION(:, :), POINTER :: col_dist_data, pgrid, row_dist_data
420 TYPE(cp_blacs_env_type), POINTER :: blacs_env
421 TYPE(distribution_2d_type), POINTER :: dist2d_p
422 TYPE(mp_para_env_type), POINTER :: para_env
423
424 dist2d_p => dist2d
425 CALL distribution_2d_get(dist2d_p, &
426 row_distribution=row_dist_data, &
427 col_distribution=col_dist_data, &
428 blacs_env=blacs_env)
429 CALL blacs_env%get(para_env=para_env, blacs2mpi=pgrid)
430
431 ! map to 1D arrays
432 row_dist => row_dist_data(:, 1)
433 col_dist => col_dist_data(:, 1)
434 !row_cluster => row_dist_data(:, 2)
435 !col_cluster => col_dist_data(:, 2)
436
437 CALL dbcsr_distribution_new(dist, &
438 group=para_env%get_handle(), pgrid=pgrid, &
439 row_dist=row_dist, &
440 col_dist=col_dist)
441
442 END SUBROUTINE cp_dbcsr_dist2d_to_dist
443
444! **************************************************************************************************
445!> \brief multiply a dbcsr with a replicated array
446!> c = alpha_scalar * A (dbscr) * b + c
447!> \param[in] matrix_a DBSCR matrxx
448!> \param[in] vec_b vectors b
449!> \param[inout] vec_c vectors c
450!> \param[in] ncol nbr of columns
451!> \param[in] alpha alpha
452!>
453! **************************************************************************************************
454 SUBROUTINE dbcsr_multiply_local(matrix_a, vec_b, vec_c, ncol, alpha)
455 TYPE(dbcsr_type), INTENT(IN) :: matrix_a
456 REAL(dp), DIMENSION(:, :), INTENT(IN) :: vec_b
457 REAL(dp), DIMENSION(:, :), INTENT(INOUT) :: vec_c
458 INTEGER, INTENT(in), OPTIONAL :: ncol
459 REAL(dp), INTENT(IN), OPTIONAL :: alpha
460
461 CHARACTER(LEN=*), PARAMETER :: routinen = 'dbcsr_multiply_local'
462
463 INTEGER :: col, coloff, my_ncol, row, rowoff, &
464 timing_handle
465 LOGICAL :: has_symm
466 REAL(dp) :: my_alpha, my_alpha2
467 REAL(dp), DIMENSION(:, :), POINTER :: data_d
468 TYPE(dbcsr_iterator_type) :: iter
469
470 CALL timeset(routinen, timing_handle)
471
472 my_alpha = 1.0_dp
473 IF (PRESENT(alpha)) my_alpha = alpha
474
475 my_ncol = SIZE(vec_b, 2)
476 IF (PRESENT(ncol)) my_ncol = ncol
477
478 my_alpha2 = 0.0_dp
479 IF (dbcsr_get_matrix_type(matrix_a) == dbcsr_type_symmetric) my_alpha2 = my_alpha
480 IF (dbcsr_get_matrix_type(matrix_a) == dbcsr_type_antisymmetric) my_alpha2 = -my_alpha
481
482 has_symm = (dbcsr_get_matrix_type(matrix_a) == dbcsr_type_symmetric .OR. &
483 dbcsr_get_matrix_type(matrix_a) == dbcsr_type_antisymmetric)
484
485!$OMP PARALLEL DEFAULT(NONE) SHARED(matrix_a,vec_b,vec_c,ncol,my_alpha2,my_alpha,my_ncol,has_symm) &
486!$OMP PRIVATE(iter,row,col,data_d,rowoff,coloff)
487 CALL dbcsr_iterator_readonly_start(iter, matrix_a, dynamic=.true., dynamic_byrows=.true.)
488 DO WHILE (dbcsr_iterator_blocks_left(iter))
489 CALL dbcsr_iterator_next_block(iter, row, col, data_d, row_offset=rowoff, col_offset=coloff)
490 IF (my_ncol /= 1) THEN
491 CALL dgemm('N', 'N', &
492 SIZE(data_d, 1), my_ncol, SIZE(data_d, 2), &
493 my_alpha, data_d(1, 1), SIZE(data_d, 1), &
494 vec_b(coloff, 1), SIZE(vec_b, 1), &
495 1.0_dp, vec_c(rowoff, 1), SIZE(vec_c, 1))
496 ELSE
497 CALL dgemv('N', SIZE(data_d, 1), SIZE(data_d, 2), &
498 my_alpha, data_d(1, 1), SIZE(data_d, 1), &
499 vec_b(coloff, 1), 1, &
500 1.0_dp, vec_c(rowoff, 1), 1)
501 END IF
502 END DO
503 CALL dbcsr_iterator_stop(iter)
504!$OMP END PARALLEL
505
506 ! FIXME ... in the symmetric case, the writes to vec_c depend on the column, not the row. This makes OMP-ing more difficult
507 ! needs e.g. a buffer for vec_c and a reduction of that buffer.
508 IF (has_symm) THEN
509 CALL dbcsr_iterator_readonly_start(iter, matrix_a)
510 DO WHILE (dbcsr_iterator_blocks_left(iter))
511 CALL dbcsr_iterator_next_block(iter, row, col, data_d, row_offset=rowoff, col_offset=coloff)
512 IF (row /= col) THEN
513 IF (my_ncol /= 1) THEN
514 CALL dgemm('T', 'N', &
515 SIZE(data_d, 2), my_ncol, SIZE(data_d, 1), &
516 my_alpha2, data_d(1, 1), SIZE(data_d, 1), &
517 vec_b(rowoff, 1), SIZE(vec_b, 1), &
518 1.0_dp, vec_c(coloff, 1), SIZE(vec_c, 1))
519 ELSE
520 CALL dgemv('T', SIZE(data_d, 1), SIZE(data_d, 2), &
521 my_alpha2, data_d(1, 1), SIZE(data_d, 1), &
522 vec_b(rowoff, 1), 1, &
523 1.0_dp, vec_c(coloff, 1), 1)
524 END IF
525 END IF
526 END DO
527 CALL dbcsr_iterator_stop(iter)
528 END IF
529
530 CALL timestop(timing_handle)
531 END SUBROUTINE dbcsr_multiply_local
532
533! **************************************************************************************************
534!> \brief multiply a dbcsr with a fm matrix
535!>
536!> For backwards compatibility with BLAS XGEMM, this routine supports
537!> the multiplication of matrices with incompatible dimensions.
538!>
539!> \param[in] matrix DBCSR matrix
540!> \param fm_in full matrix
541!> \param fm_out full matrix
542!> \param[in] ncol nbr of columns
543!> \param[in] alpha alpha
544!> \param[in] beta beta
545!>
546! **************************************************************************************************
547 SUBROUTINE cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta)
548 TYPE(dbcsr_type), INTENT(IN) :: matrix
549 TYPE(cp_fm_type), INTENT(IN) :: fm_in
550 TYPE(cp_fm_type), INTENT(INOUT) :: fm_out
551 INTEGER, INTENT(IN) :: ncol
552 REAL(dp), INTENT(IN), OPTIONAL :: alpha, beta
553
554 CHARACTER(LEN=*), PARAMETER :: routinen = 'cp_dbcsr_sm_fm_multiply'
555
556 INTEGER :: a_ncol, a_nrow, b_ncol, b_nrow, c_ncol, &
557 c_nrow, k_in, k_out, timing_handle, &
558 timing_handle_mult
559 INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_blk_size_right_in, &
560 col_blk_size_right_out, col_dist, &
561 row_blk_size, row_dist
562 TYPE(dbcsr_type) :: in, out
563 TYPE(dbcsr_distribution_type) :: dist, dist_right_in, product_dist
564 REAL(dp) :: my_alpha, my_beta
565
566 CALL timeset(routinen, timing_handle)
567
568 my_alpha = 1.0_dp
569 my_beta = 0.0_dp
570 IF (PRESENT(alpha)) my_alpha = alpha
571 IF (PRESENT(beta)) my_beta = beta
572
573 ! TODO
574 CALL cp_fm_get_info(fm_in, ncol_global=b_ncol, nrow_global=b_nrow)
575 CALL cp_fm_get_info(fm_out, ncol_global=c_ncol, nrow_global=c_nrow)
576 CALL dbcsr_get_info(matrix, nfullrows_total=a_nrow, nfullcols_total=a_ncol)
577 !WRITE(*,*) "cp_dbcsr_sm_fm_multiply: A ", a_nrow, "x", a_ncol
578 !WRITE(*,*) "cp_dbcsr_sm_fm_multiply: B ", b_nrow, "x", b_ncol
579 !WRITE(*,*) "cp_dbcsr_sm_fm_multiply: C ", c_nrow, "x", c_ncol
580
581 CALL cp_fm_get_info(fm_out, ncol_global=k_out)
582
583 CALL cp_fm_get_info(fm_in, ncol_global=k_in)
584 !write(*,*)routineN//" -----------------------------------"
585 !IF (k_in /= k_out) &
586 ! WRITE(*,'(3(A,I5,1X),2(A,F5.2,1X))')&
587 ! routineN//" ncol", ncol,'k_in',k_in,'k_out',k_out,&
588 ! 'alpha',my_alpha,'beta',my_beta
589
590 IF (ncol > 0 .AND. k_out > 0 .AND. k_in > 0) THEN
591 CALL dbcsr_get_info(matrix, row_blk_size=row_blk_size, col_blk_size=col_blk_size, distribution=dist)
592 CALL dbcsr_create_dist_r_unrot(dist_right_in, dist, k_in, col_blk_size_right_in)
593
594 CALL dbcsr_create(in, "D", dist_right_in, dbcsr_type_no_symmetry, &
595 col_blk_size, col_blk_size_right_in)
596
597 CALL dbcsr_distribution_get(dist, row_dist=row_dist)
598 CALL dbcsr_distribution_get(dist_right_in, col_dist=col_dist)
599 CALL dbcsr_distribution_new(product_dist, template=dist, &
600 row_dist=row_dist, col_dist=col_dist)
601 ALLOCATE (col_blk_size_right_out(SIZE(col_blk_size_right_in)))
602 col_blk_size_right_out = col_blk_size_right_in
603 CALL match_col_sizes(col_blk_size_right_out, col_blk_size_right_in, k_out)
604
605 !if (k_in .ne. k_out) then
606 ! write(*,*)routineN//" in cs", col_blk_size_right_in
607 ! write(*,*)routineN//" out cs", col_blk_size_right_out
608 !endif
609
610 CALL dbcsr_create(out, "D", product_dist, dbcsr_type_no_symmetry, &
611 row_blk_size, col_blk_size_right_out)
612
613 CALL copy_fm_to_dbcsr(fm_in, in)
614 IF (ncol /= k_out .OR. my_beta /= 0.0_dp) &
615 CALL copy_fm_to_dbcsr(fm_out, out)
616
617 CALL timeset(routinen//'_core', timing_handle_mult)
618 CALL dbcsr_multiply("N", "N", my_alpha, matrix, in, my_beta, out, &
619 last_column=ncol)
620 CALL timestop(timing_handle_mult)
621
622 CALL copy_dbcsr_to_fm(out, fm_out)
623
624 CALL dbcsr_release(in)
625 CALL dbcsr_release(out)
626 DEALLOCATE (col_blk_size_right_in, col_blk_size_right_out)
627 CALL dbcsr_distribution_release(dist_right_in)
628 CALL dbcsr_distribution_release(product_dist)
629
630 END IF
631
632 CALL timestop(timing_handle)
633
634 END SUBROUTINE cp_dbcsr_sm_fm_multiply
635
636! **************************************************************************************************
637!> \brief ...
638!> \param sizes1 ...
639!> \param sizes2 ...
640!> \param full_num ...
641! **************************************************************************************************
642 SUBROUTINE match_col_sizes(sizes1, sizes2, full_num)
643 INTEGER, DIMENSION(:), INTENT(INOUT) :: sizes1
644 INTEGER, DIMENSION(:), INTENT(IN) :: sizes2
645 INTEGER, INTENT(IN) :: full_num
646
647 INTEGER :: left, n1, n2, p, rm, used
648
649 n1 = SIZE(sizes1)
650 n2 = SIZE(sizes2)
651 IF (n1 /= n2) &
652 cpabort("distributions must be equal!")
653 sizes1(1:n1) = sizes2(1:n1)
654 used = sum(sizes1(1:n1))
655 ! If sizes1 does not cover everything, then we increase the
656 ! size of the last block; otherwise we reduce the blocks
657 ! (from the end) until it is small enough.
658 IF (used < full_num) THEN
659 sizes1(n1) = sizes1(n1) + full_num - used
660 ELSE
661 left = used - full_num
662 p = n1
663 DO WHILE (left > 0 .AND. p > 0)
664 rm = min(left, sizes1(p))
665 sizes1(p) = sizes1(p) - rm
666 left = left - rm
667 p = p - 1
668 END DO
669 END IF
670 END SUBROUTINE match_col_sizes
671
672! **************************************************************************************************
673!> \brief performs the multiplication sparse_matrix+dense_mat*dens_mat^T
674!> if matrix_g is not explicitly given, matrix_v^T will be used
675!> this can be important to save the necessary redistribute for a
676!> different matrix_g and increase performance.
677!> \param sparse_matrix ...
678!> \param matrix_v ...
679!> \param matrix_g ...
680!> \param ncol ...
681!> \param alpha ...
682!> \param keep_sparsity Determines if the sparsity of sparse_matrix is retained
683!> by default it is TRUE
684!> \param symmetry_mode There are the following modes
685!> 1: sparse_matrix += 0.5*alpha*(v*g^T+g^T*v) (symmetric update)
686!> -1: sparse_matrix += 0.5*alpha*(v*g^T-g^T*v) (skewsymmetric update)
687!> else: sparse_matrix += alpha*v*g^T (no symmetry, default)
688!> saves some redistribution steps
689! **************************************************************************************************
690 SUBROUTINE cp_dbcsr_plus_fm_fm_t(sparse_matrix, matrix_v, matrix_g, ncol, alpha, keep_sparsity, symmetry_mode)
691 TYPE(dbcsr_type), INTENT(INOUT) :: sparse_matrix
692 TYPE(cp_fm_type), INTENT(IN) :: matrix_v
693 TYPE(cp_fm_type), INTENT(IN), OPTIONAL :: matrix_g
694 INTEGER, INTENT(IN) :: ncol
695 REAL(kind=dp), INTENT(IN), OPTIONAL :: alpha
696 LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity
697 INTEGER, INTENT(IN), OPTIONAL :: symmetry_mode
698
699 CHARACTER(LEN=*), PARAMETER :: routinen = 'cp_dbcsr_plus_fm_fm_t'
700
701 INTEGER :: k, my_symmetry_mode, nao, npcols, &
702 timing_handle
703 INTEGER, DIMENSION(:), POINTER :: col_blk_size_left, col_dist_left, &
704 row_blk_size, row_dist
705 LOGICAL :: check_product, my_keep_sparsity
706 REAL(kind=dp) :: my_alpha, norm
707 TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp
708 TYPE(cp_fm_type) :: fm_matrix
709 TYPE(dbcsr_distribution_type) :: dist_left, sparse_dist
710 TYPE(dbcsr_type) :: mat_g, mat_v, sparse_matrix2, &
711 sparse_matrix3
712
713 check_product = .false.
714
715 CALL timeset(routinen, timing_handle)
716
717 my_keep_sparsity = .true.
718 IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity
719
720 my_symmetry_mode = 0
721 IF (PRESENT(symmetry_mode)) my_symmetry_mode = symmetry_mode
722
723 NULLIFY (col_dist_left)
724
725 IF (ncol > 0) THEN
726 IF (.NOT. dbcsr_valid_index(sparse_matrix)) &
727 cpabort("sparse_matrix must pre-exist")
728 !
729 ! Setup matrix_v
730 CALL cp_fm_get_info(matrix_v, ncol_global=k)
731 !WRITE(*,*)routineN//'truncated mult k, ncol',k,ncol,' PRESENT (matrix_g)',PRESENT (matrix_g)
732 CALL dbcsr_get_info(sparse_matrix, distribution=sparse_dist)
733 CALL dbcsr_distribution_get(sparse_dist, npcols=npcols, row_dist=row_dist)
734 CALL create_bl_distribution(col_dist_left, col_blk_size_left, k, npcols)
735 CALL dbcsr_distribution_new(dist_left, template=sparse_dist, &
736 row_dist=row_dist, col_dist=col_dist_left)
737 DEALLOCATE (col_dist_left)
738 CALL dbcsr_get_info(sparse_matrix, row_blk_size=row_blk_size)
739 CALL dbcsr_create(mat_v, "DBCSR matrix_v", dist_left, dbcsr_type_no_symmetry, &
740 row_blk_size, col_blk_size_left)
741 CALL copy_fm_to_dbcsr(matrix_v, mat_v)
742 CALL dbcsr_verify_matrix(mat_v)
743 !
744 ! Setup matrix_g
745 IF (PRESENT(matrix_g)) THEN
746 CALL dbcsr_create(mat_g, "DBCSR matrix_g", dist_left, dbcsr_type_no_symmetry, &
747 row_blk_size, col_blk_size_left)
748 CALL copy_fm_to_dbcsr(matrix_g, mat_g)
749 END IF
750 !
751 DEALLOCATE (col_blk_size_left)
752 CALL dbcsr_distribution_release(dist_left)
753 !
754 !
755 IF (check_product) THEN
756 CALL cp_fm_get_info(matrix_v, nrow_global=nao)
757 CALL cp_fm_struct_create(fm_struct_tmp, context=matrix_v%matrix_struct%context, nrow_global=nao, &
758 ncol_global=nao, para_env=matrix_v%matrix_struct%para_env)
759 CALL cp_fm_create(fm_matrix, fm_struct_tmp, name="fm matrix")
760 CALL cp_fm_struct_release(fm_struct_tmp)
761 CALL copy_dbcsr_to_fm(sparse_matrix, fm_matrix)
762 CALL dbcsr_copy(sparse_matrix3, sparse_matrix)
763 END IF
764 !
765 my_alpha = 1.0_dp
766 IF (PRESENT(alpha)) my_alpha = alpha
767 IF (PRESENT(matrix_g)) THEN
768 IF (my_symmetry_mode == 1) THEN
769 ! Symmetric mode
770 CALL dbcsr_multiply("N", "T", 0.5_dp*my_alpha, mat_v, mat_g, &
771 1.0_dp, sparse_matrix, &
772 retain_sparsity=my_keep_sparsity, &
773 last_k=ncol)
774 CALL dbcsr_multiply("N", "T", 0.5_dp*my_alpha, mat_g, mat_v, &
775 1.0_dp, sparse_matrix, &
776 retain_sparsity=my_keep_sparsity, &
777 last_k=ncol)
778 ELSE IF (my_symmetry_mode == -1) THEN
779 ! Skewsymmetric mode
780 CALL dbcsr_multiply("N", "T", 0.5_dp*my_alpha, mat_v, mat_g, &
781 1.0_dp, sparse_matrix, &
782 retain_sparsity=my_keep_sparsity, &
783 last_k=ncol)
784 CALL dbcsr_multiply("N", "T", -0.5_dp*my_alpha, mat_g, mat_v, &
785 1.0_dp, sparse_matrix, &
786 retain_sparsity=my_keep_sparsity, &
787 last_k=ncol)
788 ELSE
789 ! Normal mode
790 CALL dbcsr_multiply("N", "T", my_alpha, mat_v, mat_g, &
791 1.0_dp, sparse_matrix, &
792 retain_sparsity=my_keep_sparsity, &
793 last_k=ncol)
794 END IF
795 ELSE
796 CALL dbcsr_multiply("N", "T", my_alpha, mat_v, mat_v, &
797 1.0_dp, sparse_matrix, &
798 retain_sparsity=my_keep_sparsity, &
799 last_k=ncol)
800 END IF
801
802 IF (check_product) THEN
803 IF (PRESENT(matrix_g)) THEN
804 IF (my_symmetry_mode == 1) THEN
805 CALL cp_fm_gemm("N", "T", nao, nao, ncol, 0.5_dp*my_alpha, matrix_v, matrix_g, &
806 1.0_dp, fm_matrix)
807 CALL cp_fm_gemm("N", "T", nao, nao, ncol, 0.5_dp*my_alpha, matrix_g, matrix_v, &
808 1.0_dp, fm_matrix)
809 ELSE IF (my_symmetry_mode == -1) THEN
810 CALL cp_fm_gemm("N", "T", nao, nao, ncol, 0.5_dp*my_alpha, matrix_v, matrix_g, &
811 1.0_dp, fm_matrix)
812 CALL cp_fm_gemm("N", "T", nao, nao, ncol, -0.5_dp*my_alpha, matrix_g, matrix_v, &
813 1.0_dp, fm_matrix)
814 ELSE
815 CALL cp_fm_gemm("N", "T", nao, nao, ncol, my_alpha, matrix_v, matrix_g, &
816 1.0_dp, fm_matrix)
817 END IF
818 ELSE
819 CALL cp_fm_gemm("N", "T", nao, nao, ncol, my_alpha, matrix_v, matrix_v, &
820 1.0_dp, fm_matrix)
821 END IF
822
823 CALL dbcsr_copy(sparse_matrix2, sparse_matrix)
824 CALL dbcsr_scale(sparse_matrix2, alpha_scalar=0.0_dp)
825 CALL copy_fm_to_dbcsr(fm_matrix, sparse_matrix2, keep_sparsity=my_keep_sparsity)
826 CALL dbcsr_add(sparse_matrix2, sparse_matrix, alpha_scalar=1.0_dp, &
827 beta_scalar=-1.0_dp)
828 norm = dbcsr_frobenius_norm(sparse_matrix2)
829 WRITE (*, *) 'nao=', nao, ' k=', k, ' ncol=', ncol, ' my_alpha=', my_alpha
830 WRITE (*, *) 'PRESENT (matrix_g)', PRESENT(matrix_g)
831 WRITE (*, *) 'matrix_type=', dbcsr_get_matrix_type(sparse_matrix)
832 WRITE (*, *) 'norm(sm+alpha*v*g^t - fm+alpha*v*g^t)/n=', norm/real(nao, dp)
833 IF (norm/real(nao, dp) > 1e-12_dp) THEN
834 !WRITE(*,*) 'fm_matrix'
835 !DO j=1,SIZE(fm_matrix%local_data,2)
836 ! DO i=1,SIZE(fm_matrix%local_data,1)
837 ! WRITE(*,'(A,I3,A,I3,A,E26.16,A)') 'a(',i,',',j,')=',fm_matrix%local_data(i,j),';'
838 ! ENDDO
839 !ENDDO
840 !WRITE(*,*) 'mat_v'
841 !CALL dbcsr_print(mat_v)
842 !WRITE(*,*) 'mat_g'
843 !CALL dbcsr_print(mat_g)
844 !WRITE(*,*) 'sparse_matrix'
845 !CALL dbcsr_print(sparse_matrix)
846 !WRITE(*,*) 'sparse_matrix2 (-sm + sparse(fm))'
847 !CALL dbcsr_print(sparse_matrix2)
848 !WRITE(*,*) 'sparse_matrix3 (copy of sm input)'
849 !CALL dbcsr_print(sparse_matrix3)
850 !stop
851 END IF
852 CALL dbcsr_release(sparse_matrix2)
853 CALL dbcsr_release(sparse_matrix3)
854 CALL cp_fm_release(fm_matrix)
855 END IF
856 CALL dbcsr_release(mat_v)
857 IF (PRESENT(matrix_g)) CALL dbcsr_release(mat_g)
858 END IF
859 CALL timestop(timing_handle)
860
861 END SUBROUTINE cp_dbcsr_plus_fm_fm_t
862
863! **************************************************************************************************
864!> \brief Utility function to copy a specially shaped fm to dbcsr_matrix
865!> The result matrix will be the matrix in dbcsr format
866!> with the row blocks sizes according to the block_sizes of the template
867!> and the col blocks sizes evenly blocked with the internal dbcsr conversion
868!> size (32 is the current default)
869!> \param matrix ...
870!> \param fm_in ...
871!> \param template ...
872! **************************************************************************************************
873 SUBROUTINE cp_fm_to_dbcsr_row_template(matrix, fm_in, template)
874 TYPE(dbcsr_type), INTENT(INOUT) :: matrix
875 TYPE(cp_fm_type), INTENT(IN) :: fm_in
876 TYPE(dbcsr_type), INTENT(IN) :: template
877
878 INTEGER :: k_in
879 INTEGER, DIMENSION(:), POINTER :: col_blk_size_right_in, row_blk_size
880 TYPE(dbcsr_distribution_type) :: dist_right_in, tmpl_dist
881
882 CALL cp_fm_get_info(fm_in, ncol_global=k_in)
883
884 CALL dbcsr_get_info(template, distribution=tmpl_dist)
885 CALL dbcsr_create_dist_r_unrot(dist_right_in, tmpl_dist, k_in, col_blk_size_right_in)
886 CALL dbcsr_get_info(template, row_blk_size=row_blk_size)
887 CALL dbcsr_create(matrix, "D", dist_right_in, dbcsr_type_no_symmetry, &
888 row_blk_size, col_blk_size_right_in)
889
890 CALL copy_fm_to_dbcsr(fm_in, matrix)
891 DEALLOCATE (col_blk_size_right_in)
892 CALL dbcsr_distribution_release(dist_right_in)
893
894 END SUBROUTINE cp_fm_to_dbcsr_row_template
895
896! **************************************************************************************************
897!> \brief Utility function to create an arbitrary shaped dbcsr matrix
898!> with the same processor grid as the template matrix
899!> both row sizes and col sizes are evenly blocked with the internal
900!> dbcsr_conversion size (32 is the current default)
901!> \param matrix dbcsr matrix to be created
902!> \param template template dbcsr matrix giving its mp_env
903!> \param m global row size of output matrix
904!> \param n global col size of output matrix
905!> \param sym ...
906! **************************************************************************************************
907 SUBROUTINE cp_dbcsr_m_by_n_from_template(matrix, template, m, n, sym)
908 TYPE(dbcsr_type), INTENT(INOUT) :: matrix, template
909 INTEGER, INTENT(IN) :: m, n
910 CHARACTER, INTENT(IN), OPTIONAL :: sym
911
912 CHARACTER :: mysym
913 INTEGER :: npcols, nprows
914 INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_dist, row_blk_size, &
915 row_dist
916 TYPE(dbcsr_distribution_type) :: dist_m_n, tmpl_dist
917
918 CALL dbcsr_get_info(template, matrix_type=mysym, distribution=tmpl_dist)
919
920 IF (PRESENT(sym)) mysym = sym
921
922 NULLIFY (row_dist, col_dist)
923 NULLIFY (row_blk_size, col_blk_size)
924 !NULLIFY (row_cluster, col_cluster)
925
926 CALL dbcsr_distribution_get(tmpl_dist, nprows=nprows, npcols=npcols)
927 CALL create_bl_distribution(row_dist, row_blk_size, m, nprows)
928 CALL create_bl_distribution(col_dist, col_blk_size, n, npcols)
929 CALL dbcsr_distribution_new(dist_m_n, template=tmpl_dist, &
930 row_dist=row_dist, col_dist=col_dist, &
931 !row_cluster=row_cluster, col_cluster=col_cluster, &
932 reuse_arrays=.true.)
933
934 CALL dbcsr_create(matrix, "m_n_template", dist_m_n, mysym, &
935 row_blk_size, col_blk_size, reuse_arrays=.true.)
936 CALL dbcsr_distribution_release(dist_m_n)
937
938 END SUBROUTINE cp_dbcsr_m_by_n_from_template
939
940! **************************************************************************************************
941!> \brief Utility function to create dbcsr matrix, m x n matrix (n arbitrary)
942!> with the same processor grid and row distribution as the template matrix
943!> col sizes are evenly blocked with the internal
944!> dbcsr_conversion size (32 is the current default)
945!> \param matrix dbcsr matrix to be created
946!> \param template template dbcsr matrix giving its mp_env
947!> \param n global col size of output matrix
948!> \param sym ...
949! **************************************************************************************************
950 SUBROUTINE cp_dbcsr_m_by_n_from_row_template(matrix, template, n, sym)
951 TYPE(dbcsr_type), INTENT(INOUT) :: matrix, template
952 INTEGER :: n
953 CHARACTER, OPTIONAL :: sym
954
955 CHARACTER :: mysym
956 INTEGER :: npcols
957 INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_dist, row_blk_size, &
958 row_dist
959 TYPE(dbcsr_distribution_type) :: dist_m_n, tmpl_dist
960
961 mysym = dbcsr_get_matrix_type(template)
962 IF (PRESENT(sym)) mysym = sym
963
964 CALL dbcsr_get_info(template, distribution=tmpl_dist)
965 CALL dbcsr_distribution_get(tmpl_dist, &
966 npcols=npcols, &
967 row_dist=row_dist)
968
969 NULLIFY (col_dist, col_blk_size)
970 CALL create_bl_distribution(col_dist, col_blk_size, n, npcols)
971 CALL dbcsr_distribution_new(dist_m_n, template=tmpl_dist, &
972 row_dist=row_dist, col_dist=col_dist)
973
974 CALL dbcsr_get_info(template, row_blk_size=row_blk_size)
975 CALL dbcsr_create(matrix, "m_n_template", dist_m_n, mysym, row_blk_size, col_blk_size)
976
977 DEALLOCATE (col_dist, col_blk_size)
978 CALL dbcsr_distribution_release(dist_m_n)
979
980 END SUBROUTINE cp_dbcsr_m_by_n_from_row_template
981
982! **************************************************************************************************
983!> \brief Distributes elements into blocks and into bins
984!>
985!> \param[out] block_distribution block distribution to bins
986!> \param[out] block_size sizes of blocks
987!> \param[in] nelements number of elements to bin
988!> \param[in] nbins number of bins
989!> \par Term clarification
990!> An example: blocks are atom blocks and bins are process rows/columns.
991! **************************************************************************************************
992 SUBROUTINE create_bl_distribution(block_distribution, &
993 block_size, nelements, nbins)
994 INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: block_distribution, block_size
995 INTEGER, INTENT(IN) :: nelements, nbins
996
997 CHARACTER(len=*), PARAMETER :: routinen = 'create_bl_distribution', &
998 routinep = modulen//':'//routinen
999
1000 INTEGER :: bin, blk_layer, element_stack, els, &
1001 estimated_blocks, max_blocks_per_bin, &
1002 nblks, nblocks, stat
1003 INTEGER, DIMENSION(:), POINTER :: blk_dist, blk_sizes
1004
1005! ---------------------------------------------------------------------------
1006
1007 NULLIFY (block_distribution)
1008 NULLIFY (block_size)
1009 ! Define the sizes on which we build the distribution.
1010 IF (nelements > 0) THEN
1011
1012 nblocks = ceiling(real(nelements, kind=dp)/real(max_elements_per_block, kind=dp))
1013 max_blocks_per_bin = ceiling(real(nblocks, kind=dp)/real(nbins, kind=dp))
1014
1015 IF (debug_mod) THEN
1016 WRITE (*, '(1X,A,1X,A,I7,A,I7,A)') routinep, "For", nelements, &
1017 " elements and", nbins, " bins"
1018 WRITE (*, '(1X,A,1X,A,I7,A)') routinep, "There are", &
1019 max_elements_per_block, " max elements per block"
1020 WRITE (*, '(1X,A,1X,A,I7,A)') routinep, "There are", &
1021 nblocks, " blocks"
1022 WRITE (*, '(1X,A,1X,A,I7,A)') routinep, "There are", &
1023 max_blocks_per_bin, " max blocks/bin"
1024 END IF
1025
1026 estimated_blocks = max_blocks_per_bin*nbins
1027 ALLOCATE (blk_dist(estimated_blocks), stat=stat)
1028 IF (stat /= 0) &
1029 cpabort("blk_dist")
1030 ALLOCATE (blk_sizes(estimated_blocks), stat=stat)
1031 IF (stat /= 0) &
1032 cpabort("blk_sizes")
1033 element_stack = 0
1034 nblks = 0
1035 DO blk_layer = 1, max_blocks_per_bin
1036 DO bin = 0, nbins - 1
1037 els = min(max_elements_per_block, nelements - element_stack)
1038 IF (els > 0) THEN
1039 element_stack = element_stack + els
1040 nblks = nblks + 1
1041 blk_dist(nblks) = bin
1042 blk_sizes(nblks) = els
1043 IF (debug_mod) WRITE (*, '(1X,A,I5,A,I5,A,I5)') routinep//" Assigning", &
1044 els, " elements as block", nblks, " to bin", bin
1045 END IF
1046 END DO
1047 END DO
1048 ! Create the output arrays.
1049 IF (nblks == estimated_blocks) THEN
1050 block_distribution => blk_dist
1051 block_size => blk_sizes
1052 ELSE
1053 ALLOCATE (block_distribution(nblks), stat=stat)
1054 IF (stat /= 0) &
1055 cpabort("blk_dist")
1056 block_distribution(:) = blk_dist(1:nblks)
1057 DEALLOCATE (blk_dist)
1058 ALLOCATE (block_size(nblks), stat=stat)
1059 IF (stat /= 0) &
1060 cpabort("blk_sizes")
1061 block_size(:) = blk_sizes(1:nblks)
1062 DEALLOCATE (blk_sizes)
1063 END IF
1064 ELSE
1065 ALLOCATE (block_distribution(0), stat=stat)
1066 IF (stat /= 0) &
1067 cpabort("blk_dist")
1068 ALLOCATE (block_size(0), stat=stat)
1069 IF (stat /= 0) &
1070 cpabort("blk_sizes")
1071 END IF
10721579 FORMAT(i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5)
1073 IF (debug_mod) THEN
1074 WRITE (*, '(1X,A,A)') routinep//" Distribution"
1075 WRITE (*, 1579) block_distribution(:)
1076 WRITE (*, '(1X,A,A)') routinep//" Sizes"
1077 WRITE (*, 1579) block_size(:)
1078 END IF
1079 END SUBROUTINE create_bl_distribution
1080
1081! **************************************************************************************************
1082!> \brief Creates a new distribution for the right matrix in a matrix
1083!> multiplication with unrotated grid.
1084!> \param[out] dist_right new distribution for the right matrix
1085!> \param[in] dist_left the distribution of the left matrix
1086!> \param[in] ncolumns number of columns in right matrix
1087!> \param[out] right_col_blk_sizes sizes of blocks in the created column
1088!> \par The new row distribution for the right matrix is the same as the row
1089!> distribution of the left matrix, while the column distribution is
1090!> created so that it is appropriate to the parallel environment.
1091! **************************************************************************************************
1092 SUBROUTINE dbcsr_create_dist_r_unrot(dist_right, dist_left, ncolumns, &
1093 right_col_blk_sizes)
1094 TYPE(dbcsr_distribution_type), INTENT(OUT) :: dist_right
1095 TYPE(dbcsr_distribution_type), INTENT(IN) :: dist_left
1096 INTEGER, INTENT(IN) :: ncolumns
1097 INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: right_col_blk_sizes
1098
1099 INTEGER :: multiplicity, ncols, nimages, npcols, &
1100 nprows
1101 INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_images
1102 INTEGER, DIMENSION(:), POINTER :: old_col_dist, right_col_dist, &
1103 right_row_dist
1104
1105 CALL dbcsr_distribution_get(dist_left, &
1106 ncols=ncols, &
1107 col_dist=old_col_dist, &
1108 nprows=nprows, &
1109 npcols=npcols)
1110
1111 ! Create the column distribution
1112 CALL create_bl_distribution(right_col_dist, right_col_blk_sizes, ncolumns, npcols)
1113 ! Create an even row distribution.
1114 ALLOCATE (right_row_dist(ncols), tmp_images(ncols))
1115 nimages = lcm(nprows, npcols)/nprows
1116 multiplicity = nprows/gcd(nprows, npcols)
1117 CALL rebin_distribution(right_row_dist, tmp_images, old_col_dist, nprows, multiplicity, nimages)
1118
1119 CALL dbcsr_distribution_new(dist_right, &
1120 template=dist_left, &
1121 row_dist=right_row_dist, &
1122 col_dist=right_col_dist, &
1123 !row_cluster=dummy,&
1124 !col_cluster=dummy,&
1125 reuse_arrays=.true.)
1126 DEALLOCATE (tmp_images)
1127 END SUBROUTINE dbcsr_create_dist_r_unrot
1128
1129! **************************************************************************************************
1130!> \brief Makes new distribution with decimation and multiplicity
1131!> \param[out] new_bins new real distribution
1132!> \param[out] images new image distribution
1133!> \param[in] source_bins Basis for the new distribution and images
1134!> \param[in] nbins number of bins in the new real distribution
1135!> \param[in] multiplicity multiplicity
1136!> \param[in] nimages number of images in the new distribution
1137!> \par Definition of multiplicity and nimages
1138!> Multiplicity and decimation (number of images) are used to
1139!> match process grid coordinates on non-square process
1140!> grids. Given source_nbins and target_nbins, their relation is
1141!> source_nbins * target_multiplicity
1142!> = target_nbins * target_nimages.
1143!> It is best when both multiplicity and nimages are small. To
1144!> get these two factors, then, one can use the following formulas:
1145!> nimages = lcm(source_nbins, target_nbins) / target_nbins
1146!> multiplicity = target_nbins / gcd(source_nbins, target_nbins)
1147!> from the target's point of view (nimages = target_nimages).
1148!> \par Mapping
1149!> The new distribution comprises of real bins and images within
1150!> bins. These can be view as target_nbins*nimages virtual
1151!> columns. These same virtual columns are also
1152!> source_nbins*multiplicity in number. Therefore these virtual
1153!> columns are mapped from source_nbins*multiplicity onto
1154!> target_bins*nimages (each target bin has nimages images):
1155!> Source 4: |1 2 3|4 5 6|7 8 9|A B C| (4*3)
1156!> Target 6: |1 2|3 4|5 6|7 8|9 A|B C| (6*2)
1157!> multiplicity=3, nimages=2, 12 virtual columns (1-C).
1158!> Source bin elements are evenly mapped into one of multiplicity
1159!> virtual columns. Other (non-even, block-size aware) mappings
1160!> could be better.
1161! **************************************************************************************************
1162 SUBROUTINE rebin_distribution(new_bins, images, source_bins, &
1163 nbins, multiplicity, nimages)
1164 INTEGER, DIMENSION(:), INTENT(OUT) :: new_bins, images
1165 INTEGER, DIMENSION(:), INTENT(IN) :: source_bins
1166 INTEGER, INTENT(IN) :: nbins, multiplicity, nimages
1167
1168 INTEGER :: bin, i, old_nbins, virtual_bin
1169 INTEGER, ALLOCATABLE, DIMENSION(:) :: bin_multiplier
1170
1171! ---------------------------------------------------------------------------
1172
1173 IF (mod(nbins*nimages, multiplicity) /= 0) THEN
1174 cpwarn("mulitplicity is not divisor of new process grid coordinate")
1175 END IF
1176 old_nbins = (nbins*nimages)/multiplicity
1177 ALLOCATE (bin_multiplier(0:old_nbins - 1))
1178 bin_multiplier(:) = 0
1179 DO i = 1, SIZE(new_bins)
1180 IF (i <= SIZE(source_bins)) THEN
1181 bin = source_bins(i)
1182 ELSE
1183 ! Fill remainder with a cyclic distribution
1184 bin = mod(i, old_nbins)
1185 END IF
1186 virtual_bin = bin*multiplicity + bin_multiplier(bin)
1187 new_bins(i) = virtual_bin/nimages
1188 images(i) = 1 + mod(virtual_bin, nimages)
1189 bin_multiplier(bin) = bin_multiplier(bin) + 1
1190 IF (bin_multiplier(bin) >= multiplicity) THEN
1191 bin_multiplier(bin) = 0
1192 END IF
1193 END DO
1194 END SUBROUTINE rebin_distribution
1195
1196! **************************************************************************************************
1197!> \brief Creates a block-cyclic compatible distribution
1198!>
1199!> All blocks in a dimension, except for possibly the last
1200!> block, have the same size.
1201!> \param[out] dist the elemental distribution
1202!> \param[in] nrows number of full rows
1203!> \param[in] ncolumns number of full columns
1204!> \param[in] nrow_block size of row blocks
1205!> \param[in] ncol_block size of column blocks
1206!> \param group_handle ...
1207!> \param pgrid ...
1208!> \param[out] row_blk_sizes row block sizes
1209!> \param[out] col_blk_sizes column block sizes
1210! **************************************************************************************************
1211 SUBROUTINE dbcsr_create_dist_block_cyclic(dist, nrows, ncolumns, &
1212 nrow_block, ncol_block, group_handle, pgrid, row_blk_sizes, col_blk_sizes)
1213 TYPE(dbcsr_distribution_type), INTENT(OUT) :: dist
1214 INTEGER, INTENT(IN) :: nrows, ncolumns, nrow_block, ncol_block, &
1215 group_handle
1216 INTEGER, DIMENSION(:, :), POINTER :: pgrid
1217 INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: row_blk_sizes, col_blk_sizes
1218
1219 CHARACTER(len=*), PARAMETER :: routinen = 'dbcsr_create_dist_block_cyclic'
1220
1221 INTEGER :: nblkcols, nblkrows, npcols, nprows, &
1222 pdim, sz
1223 INTEGER, DIMENSION(:), POINTER :: cd_data, rd_data
1224
1225 ! Row sizes
1226 IF (nrow_block == 0) THEN
1227 nblkrows = 0
1228 sz = 0
1229 ELSE
1230 nblkrows = nrows/nrow_block
1231 sz = mod(nrows, nrow_block)
1232 END IF
1233 IF (sz > 0) nblkrows = nblkrows + 1
1234 ALLOCATE (row_blk_sizes(nblkrows), rd_data(nblkrows))
1235 row_blk_sizes = nrow_block
1236 IF (sz /= 0) row_blk_sizes(nblkrows) = sz
1237
1238 ! Column sizes
1239 IF (ncol_block == 0) THEN
1240 nblkcols = 0
1241 sz = 0
1242 ELSE
1243 nblkcols = ncolumns/ncol_block
1244 sz = mod(ncolumns, ncol_block)
1245 END IF
1246 IF (sz > 0) nblkcols = nblkcols + 1
1247 ALLOCATE (col_blk_sizes(nblkcols), cd_data(nblkcols))
1248 col_blk_sizes = ncol_block
1249 IF (sz /= 0) col_blk_sizes(nblkcols) = sz
1250 !
1251 IF (debug_mod) THEN
1252 WRITE (*, *) routinen//" nrows,nrow_block,nblkrows=", &
1253 nrows, nrow_block, nblkrows
1254 WRITE (*, *) routinen//" ncols,ncol_block,nblkcols=", &
1255 ncolumns, ncol_block, nblkcols
1256 END IF
1257 ! Calculate process row distribution
1258 nprows = SIZE(pgrid, 1)
1259 DO pdim = 0, min(nprows - 1, nblkrows - 1)
1260 rd_data(1 + pdim:nblkrows:nprows) = pdim
1261 END DO
1262 ! Calculate process column distribution
1263 npcols = SIZE(pgrid, 2)
1264 DO pdim = 0, min(npcols - 1, nblkcols - 1)
1265 cd_data(1 + pdim:nblkcols:npcols) = pdim
1266 END DO
1267 !
1268 IF (debug_mod) THEN
1269 WRITE (*, *) routinen//" row_dist", &
1270 rd_data
1271 WRITE (*, *) routinen//" col_dist", &
1272 cd_data
1273 END IF
1274 !
1275 CALL dbcsr_distribution_new(dist, &
1276 group=group_handle, pgrid=pgrid, &
1277 row_dist=rd_data, &
1278 col_dist=cd_data, &
1279 reuse_arrays=.true.)
1280
1281 END SUBROUTINE dbcsr_create_dist_block_cyclic
1282
1283! **************************************************************************************************
1284!> \brief Allocate and initialize a real matrix 1-dimensional set.
1285!> \param[in,out] matrix_set Set containing the DBCSR matrices
1286!> \param[in] nmatrix Size of set
1287!> \par History
1288!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1289! **************************************************************************************************
1290 SUBROUTINE allocate_dbcsr_matrix_set_1d(matrix_set, nmatrix)
1291 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_set
1292 INTEGER, INTENT(IN) :: nmatrix
1293
1294 INTEGER :: imatrix
1295
1296 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1297 ALLOCATE (matrix_set(nmatrix))
1298 DO imatrix = 1, nmatrix
1299 NULLIFY (matrix_set(imatrix)%matrix)
1300 END DO
1301 END SUBROUTINE allocate_dbcsr_matrix_set_1d
1302
1303! **************************************************************************************************
1304!> \brief Allocate and initialize a real matrix 2-dimensional set.
1305!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1306!> \param[in] nmatrix Size of set
1307!> \param mmatrix ...
1308!> \par History
1309!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1310! **************************************************************************************************
1311 SUBROUTINE allocate_dbcsr_matrix_set_2d(matrix_set, nmatrix, mmatrix)
1312 TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_set
1313 INTEGER, INTENT(IN) :: nmatrix, mmatrix
1314
1315 INTEGER :: imatrix, jmatrix
1316
1317 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1318 ALLOCATE (matrix_set(nmatrix, mmatrix))
1319 DO jmatrix = 1, mmatrix
1320 DO imatrix = 1, nmatrix
1321 NULLIFY (matrix_set(imatrix, jmatrix)%matrix)
1322 END DO
1323 END DO
1324 END SUBROUTINE allocate_dbcsr_matrix_set_2d
1325
1326! **************************************************************************************************
1327!> \brief Allocate and initialize a real matrix 3-dimensional set.
1328!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1329!> \param[in] nmatrix Size of set
1330!> \param mmatrix ...
1331!> \param pmatrix ...
1332!> \par History
1333!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1334! **************************************************************************************************
1335 SUBROUTINE allocate_dbcsr_matrix_set_3d(matrix_set, nmatrix, mmatrix, pmatrix)
1336 TYPE(dbcsr_p_type), DIMENSION(:, :, :), POINTER :: matrix_set
1337 INTEGER, INTENT(IN) :: nmatrix, mmatrix, pmatrix
1338
1339 INTEGER :: imatrix, jmatrix, kmatrix
1340
1341 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1342 ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix))
1343 DO kmatrix = 1, pmatrix
1344 DO jmatrix = 1, mmatrix
1345 DO imatrix = 1, nmatrix
1346 NULLIFY (matrix_set(imatrix, jmatrix, kmatrix)%matrix)
1347 END DO
1348 END DO
1349 END DO
1350 END SUBROUTINE allocate_dbcsr_matrix_set_3d
1351
1352! **************************************************************************************************
1353!> \brief Allocate and initialize a real matrix 4-dimensional set.
1354!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1355!> \param[in] nmatrix Size of set
1356!> \param mmatrix ...
1357!> \param pmatrix ...
1358!> \param qmatrix ...
1359!> \par History
1360!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1361! **************************************************************************************************
1362 SUBROUTINE allocate_dbcsr_matrix_set_4d(matrix_set, nmatrix, mmatrix, pmatrix, qmatrix)
1363 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :), POINTER :: matrix_set
1364 INTEGER, INTENT(IN) :: nmatrix, mmatrix, pmatrix, qmatrix
1365
1366 INTEGER :: imatrix, jmatrix, kmatrix, lmatrix
1367
1368 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1369 ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix, qmatrix))
1370 DO lmatrix = 1, qmatrix
1371 DO kmatrix = 1, pmatrix
1372 DO jmatrix = 1, mmatrix
1373 DO imatrix = 1, nmatrix
1374 NULLIFY (matrix_set(imatrix, jmatrix, kmatrix, lmatrix)%matrix)
1375 END DO
1376 END DO
1377 END DO
1378 END DO
1379 END SUBROUTINE allocate_dbcsr_matrix_set_4d
1380
1381! **************************************************************************************************
1382!> \brief Allocate and initialize a real matrix 5-dimensional set.
1383!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1384!> \param[in] nmatrix Size of set
1385!> \param mmatrix ...
1386!> \param pmatrix ...
1387!> \param qmatrix ...
1388!> \param smatrix ...
1389!> \par History
1390!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1391! **************************************************************************************************
1392 SUBROUTINE allocate_dbcsr_matrix_set_5d(matrix_set, nmatrix, mmatrix, pmatrix, qmatrix, smatrix)
1393 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :, :), &
1394 POINTER :: matrix_set
1395 INTEGER, INTENT(IN) :: nmatrix, mmatrix, pmatrix, qmatrix, &
1396 smatrix
1397
1398 INTEGER :: hmatrix, imatrix, jmatrix, kmatrix, &
1399 lmatrix
1400
1401 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1402 ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix, qmatrix, smatrix))
1403 DO hmatrix = 1, smatrix
1404 DO lmatrix = 1, qmatrix
1405 DO kmatrix = 1, pmatrix
1406 DO jmatrix = 1, mmatrix
1407 DO imatrix = 1, nmatrix
1408 NULLIFY (matrix_set(imatrix, jmatrix, kmatrix, lmatrix, hmatrix)%matrix)
1409 END DO
1410 END DO
1411 END DO
1412 END DO
1413 END DO
1414 END SUBROUTINE allocate_dbcsr_matrix_set_5d
1415
1416 ! **************************************************************************************************
1417!> \brief Deallocate a real matrix set and release all of the member matrices.
1418!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1419!> \par History
1420!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1421! **************************************************************************************************
1422 SUBROUTINE deallocate_dbcsr_matrix_set_1d(matrix_set)
1423
1424 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_set
1425
1426 INTEGER :: imatrix
1427
1428 IF (ASSOCIATED(matrix_set)) THEN
1429 DO imatrix = 1, SIZE(matrix_set)
1430 CALL dbcsr_deallocate_matrix(matrix_set(imatrix)%matrix)
1431 END DO
1432 DEALLOCATE (matrix_set)
1433 END IF
1434
1435 END SUBROUTINE deallocate_dbcsr_matrix_set_1d
1436
1437! **************************************************************************************************
1438!> \brief Deallocate a real matrix set and release all of the member matrices.
1439!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1440!> \par History
1441!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1442! **************************************************************************************************
1443 SUBROUTINE deallocate_dbcsr_matrix_set_2d(matrix_set)
1444
1445 TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_set
1446
1447 INTEGER :: imatrix, jmatrix
1448
1449 IF (ASSOCIATED(matrix_set)) THEN
1450 DO jmatrix = 1, SIZE(matrix_set, 2)
1451 DO imatrix = 1, SIZE(matrix_set, 1)
1452 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix)%matrix)
1453 END DO
1454 END DO
1455 DEALLOCATE (matrix_set)
1456 END IF
1457 END SUBROUTINE deallocate_dbcsr_matrix_set_2d
1458
1459! **************************************************************************************************
1460!> \brief Deallocate a real matrix set and release all of the member matrices.
1461!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1462!> \par History
1463!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1464! **************************************************************************************************
1465 SUBROUTINE deallocate_dbcsr_matrix_set_3d(matrix_set)
1466
1467 TYPE(dbcsr_p_type), DIMENSION(:, :, :), POINTER :: matrix_set
1468
1469 INTEGER :: imatrix, jmatrix, kmatrix
1470
1471 IF (ASSOCIATED(matrix_set)) THEN
1472 DO kmatrix = 1, SIZE(matrix_set, 3)
1473 DO jmatrix = 1, SIZE(matrix_set, 2)
1474 DO imatrix = 1, SIZE(matrix_set, 1)
1475 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix)%matrix)
1476 END DO
1477 END DO
1478 END DO
1479 DEALLOCATE (matrix_set)
1480 END IF
1481 END SUBROUTINE deallocate_dbcsr_matrix_set_3d
1482
1483! **************************************************************************************************
1484!> \brief Deallocate a real matrix set and release all of the member matrices.
1485!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1486!> \par History
1487!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1488! **************************************************************************************************
1489 SUBROUTINE deallocate_dbcsr_matrix_set_4d(matrix_set)
1490
1491 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :), POINTER :: matrix_set
1492
1493 INTEGER :: imatrix, jmatrix, kmatrix, lmatrix
1494
1495 IF (ASSOCIATED(matrix_set)) THEN
1496 DO lmatrix = 1, SIZE(matrix_set, 4)
1497 DO kmatrix = 1, SIZE(matrix_set, 3)
1498 DO jmatrix = 1, SIZE(matrix_set, 2)
1499 DO imatrix = 1, SIZE(matrix_set, 1)
1500 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix, lmatrix)%matrix)
1501 END DO
1502 END DO
1503 END DO
1504 END DO
1505 DEALLOCATE (matrix_set)
1506 END IF
1507 END SUBROUTINE deallocate_dbcsr_matrix_set_4d
1508
1509! **************************************************************************************************
1510!> \brief Deallocate a real matrix set and release all of the member matrices.
1511!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1512!> \par History
1513!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1514! **************************************************************************************************
1515 SUBROUTINE deallocate_dbcsr_matrix_set_5d(matrix_set)
1516
1517 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :, :), &
1518 POINTER :: matrix_set
1519
1520 INTEGER :: hmatrix, imatrix, jmatrix, kmatrix, &
1521 lmatrix
1522
1523 IF (ASSOCIATED(matrix_set)) THEN
1524 DO hmatrix = 1, SIZE(matrix_set, 5)
1525 DO lmatrix = 1, SIZE(matrix_set, 4)
1526 DO kmatrix = 1, SIZE(matrix_set, 3)
1527 DO jmatrix = 1, SIZE(matrix_set, 2)
1528 DO imatrix = 1, SIZE(matrix_set, 1)
1529 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix, lmatrix, hmatrix)%matrix)
1530 END DO
1531 END DO
1532 END DO
1533 END DO
1534 END DO
1535 DEALLOCATE (matrix_set)
1536 END IF
1537 END SUBROUTINE deallocate_dbcsr_matrix_set_5d
1538
1539END MODULE cp_dbcsr_operations
dgemm
static void dgemm(const char transa, const char transb, const int m, const int n, const int k, const double alpha, const double *a, const int lda, const double *b, const int ldb, const double beta, double *c, const int ldc)
Convenient wrapper to hide Fortran nature of dgemm_, swapping a and b.
Definition grid_cpu_task_list.c:225
cp_dbcsr_api::dbcsr_create
Definition cp_dbcsr_api.F:194
cp_dbcsr_operations::dbcsr_allocate_matrix_set
Definition cp_dbcsr_operations.F:77
cp_dbcsr_operations::dbcsr_deallocate_matrix_set
Definition cp_dbcsr_operations.F:85
cp_fm_types::cp_fm_release
Definition cp_fm_types.F:88
cp_fm_types::cp_fm_to_fm
Definition cp_fm_types.F:83
cp_blacs_env
methods related to the blacs parallel environment
Definition cp_blacs_env.F:15
cp_dbcsr_api
Definition cp_dbcsr_api.F:8
cp_dbcsr_api::dbcsr_verify_matrix
subroutine, public dbcsr_verify_matrix(matrix, verbosity, local)
...
Definition cp_dbcsr_api.F:1286
cp_dbcsr_api::dbcsr_distribution_release
subroutine, public dbcsr_distribution_release(dist)
...
Definition cp_dbcsr_api.F:642
cp_dbcsr_api::dbcsr_scale
subroutine, public dbcsr_scale(matrix, alpha_scalar)
...
Definition cp_dbcsr_api.F:1187
cp_dbcsr_api::dbcsr_distribution_new
subroutine, public dbcsr_distribution_new(dist, template, group, pgrid, row_dist, col_dist, reuse_arrays)
...
Definition cp_dbcsr_api.F:615
cp_dbcsr_api::dbcsr_deallocate_matrix
subroutine, public dbcsr_deallocate_matrix(matrix)
...
Definition cp_dbcsr_api.F:235
cp_dbcsr_api::dbcsr_get_matrix_type
character function, public dbcsr_get_matrix_type(matrix)
...
Definition cp_dbcsr_api.F:860
cp_dbcsr_api::dbcsr_iterator_blocks_left
logical function, public dbcsr_iterator_blocks_left(iterator)
...
Definition cp_dbcsr_api.F:943
cp_dbcsr_api::dbcsr_iterator_stop
subroutine, public dbcsr_iterator_stop(iterator)
...
Definition cp_dbcsr_api.F:1049
cp_dbcsr_api::dbcsr_valid_index
logical function, public dbcsr_valid_index(matrix)
...
Definition cp_dbcsr_api.F:1269
cp_dbcsr_api::dbcsr_desymmetrize
subroutine, public dbcsr_desymmetrize(matrix_a, matrix_b)
...
Definition cp_dbcsr_api.F:524
cp_dbcsr_api::dbcsr_copy
subroutine, public dbcsr_copy(matrix_b, matrix_a, name, keep_sparsity, keep_imaginary)
...
Definition cp_dbcsr_api.F:370
cp_dbcsr_api::dbcsr_multiply
subroutine, public dbcsr_multiply(transa, transb, alpha, matrix_a, matrix_b, beta, matrix_c, first_row, last_row, first_column, last_column, first_k, last_k, retain_sparsity, filter_eps, flop)
...
Definition cp_dbcsr_api.F:1095
cp_dbcsr_api::dbcsr_get_info
subroutine, public dbcsr_get_info(matrix, nblkrows_total, nblkcols_total, nfullrows_total, nfullcols_total, nblkrows_local, nblkcols_local, nfullrows_local, nfullcols_local, my_prow, my_pcol, local_rows, local_cols, proc_row_dist, proc_col_dist, row_blk_size, col_blk_size, row_blk_offset, col_blk_offset, distribution, name, matrix_type, group)
...
Definition cp_dbcsr_api.F:807
cp_dbcsr_api::dbcsr_iterator_next_block
subroutine, public dbcsr_iterator_next_block(iterator, row, column, block, block_number_argument_has_been_removed, row_size, col_size, row_offset, col_offset, transposed)
...
Definition cp_dbcsr_api.F:970
cp_dbcsr_api::dbcsr_iterator_start
subroutine, public dbcsr_iterator_start(iterator, matrix, shared, dynamic, dynamic_byrows)
...
Definition cp_dbcsr_api.F:1011
cp_dbcsr_api::dbcsr_release
subroutine, public dbcsr_release(matrix)
...
Definition cp_dbcsr_api.F:1141
cp_dbcsr_api::dbcsr_complete_redistribute
subroutine, public dbcsr_complete_redistribute(matrix, redist)
...
Definition cp_dbcsr_api.F:319
cp_dbcsr_api::dbcsr_iterator_readonly_start
subroutine, public dbcsr_iterator_readonly_start(iterator, matrix, shared, dynamic, dynamic_byrows)
Like dbcsr_iterator_start() but with matrix being INTENT(IN). When invoking this routine,...
Definition cp_dbcsr_api.F:1032
cp_dbcsr_api::dbcsr_add
subroutine, public dbcsr_add(matrix_a, matrix_b, alpha_scalar, beta_scalar)
...
Definition cp_dbcsr_api.F:253
cp_dbcsr_api::dbcsr_distribution_get
subroutine, public dbcsr_distribution_get(dist, row_dist, col_dist, nrows, ncols, has_threads, group, mynode, numnodes, nprows, npcols, myprow, mypcol, pgrid, subgroups_defined, prow_group, pcol_group)
...
Definition cp_dbcsr_api.F:571
cp_dbcsr_contrib
Definition cp_dbcsr_contrib.F:8
cp_dbcsr_contrib::dbcsr_reserve_all_blocks
subroutine, public dbcsr_reserve_all_blocks(matrix)
Reserves all blocks.
Definition cp_dbcsr_contrib.F:295
cp_dbcsr_contrib::dbcsr_frobenius_norm
real(dp) function, public dbcsr_frobenius_norm(matrix)
Compute the frobenius norm of a dbcsr matrix.
Definition cp_dbcsr_contrib.F:127
cp_dbcsr_operations
DBCSR operations in CP2K.
Definition cp_dbcsr_operations.F:18
cp_dbcsr_operations::cp_dbcsr_sm_fm_multiply
subroutine, public cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta)
multiply a dbcsr with a fm matrix
Definition cp_dbcsr_operations.F:548
cp_dbcsr_operations::max_elements_per_block
integer, save, public max_elements_per_block
Definition cp_dbcsr_operations.F:57
cp_dbcsr_operations::dbcsr_create_dist_r_unrot
subroutine, public dbcsr_create_dist_r_unrot(dist_right, dist_left, ncolumns, right_col_blk_sizes)
Creates a new distribution for the right matrix in a matrix multiplication with unrotated grid.
Definition cp_dbcsr_operations.F:1094
cp_dbcsr_operations::dbcsr_multiply_local
subroutine, public dbcsr_multiply_local(matrix_a, vec_b, vec_c, ncol, alpha)
multiply a dbcsr with a replicated array c = alpha_scalar * A (dbscr) * b + c
Definition cp_dbcsr_operations.F:455
cp_dbcsr_operations::cp_dbcsr_dist2d_to_dist
subroutine, public cp_dbcsr_dist2d_to_dist(dist2d, dist)
Creates a DBCSR distribution from a distribution_2d.
Definition cp_dbcsr_operations.F:415
cp_dbcsr_operations::copy_dbcsr_to_fm
subroutine, public copy_dbcsr_to_fm(matrix, fm)
Copy a DBCSR matrix to a BLACS matrix.
Definition cp_dbcsr_operations.F:212
cp_dbcsr_operations::copy_fm_to_dbcsr_bc
subroutine, public copy_fm_to_dbcsr_bc(fm, bc_mat)
Copy a BLACS matrix to a dbcsr matrix with a special block-cyclic distribution, which requires no com...
Definition cp_dbcsr_operations.F:149
cp_dbcsr_operations::copy_dbcsr_to_fm_bc
subroutine, public copy_dbcsr_to_fm_bc(bc_mat, fm)
Copy a DBCSR_BLACS matrix to a BLACS matrix.
Definition cp_dbcsr_operations.F:273
cp_dbcsr_operations::cp_fm_to_dbcsr_row_template
subroutine, public cp_fm_to_dbcsr_row_template(matrix, fm_in, template)
Utility function to copy a specially shaped fm to dbcsr_matrix The result matrix will be the matrix i...
Definition cp_dbcsr_operations.F:874
cp_dbcsr_operations::cp_dbcsr_m_by_n_from_row_template
subroutine, public cp_dbcsr_m_by_n_from_row_template(matrix, template, n, sym)
Utility function to create dbcsr matrix, m x n matrix (n arbitrary) with the same processor grid and ...
Definition cp_dbcsr_operations.F:951
cp_dbcsr_operations::cp_dbcsr_plus_fm_fm_t
subroutine, public cp_dbcsr_plus_fm_fm_t(sparse_matrix, matrix_v, matrix_g, ncol, alpha, keep_sparsity, symmetry_mode)
performs the multiplication sparse_matrix+dense_mat*dens_mat^T if matrix_g is not explicitly given,...
Definition cp_dbcsr_operations.F:691
cp_dbcsr_operations::cp_dbcsr_m_by_n_from_template
subroutine, public cp_dbcsr_m_by_n_from_template(matrix, template, m, n, sym)
Utility function to create an arbitrary shaped dbcsr matrix with the same processor grid as the templ...
Definition cp_dbcsr_operations.F:908
cp_dbcsr_operations::dbcsr_copy_columns_hack
subroutine, public dbcsr_copy_columns_hack(matrix_b, matrix_a, ncol, source_start, target_start, para_env, blacs_env)
hack for dbcsr_copy_columns
Definition cp_dbcsr_operations.F:371
cp_dbcsr_operations::copy_fm_to_dbcsr
subroutine, public copy_fm_to_dbcsr(fm, matrix, keep_sparsity)
Copy a BLACS matrix to a dbcsr matrix.
Definition cp_dbcsr_operations.F:111
cp_fm_basic_linalg
Basic linear algebra operations for full matrices.
Definition cp_fm_basic_linalg.F:14
cp_fm_basic_linalg::cp_fm_gemm
subroutine, public cp_fm_gemm(transa, transb, m, n, k, alpha, matrix_a, matrix_b, beta, matrix_c, a_first_col, a_first_row, b_first_col, b_first_row, c_first_col, c_first_row)
computes matrix_c = beta * matrix_c + alpha * ( matrix_a ** transa ) * ( matrix_b ** transb )
Definition cp_fm_basic_linalg.F:477
cp_fm_struct
represent the structure of a full matrix
Definition cp_fm_struct.F:14
cp_fm_struct::cp_fm_struct_create
subroutine, public cp_fm_struct_create(fmstruct, para_env, context, nrow_global, ncol_global, nrow_block, ncol_block, descriptor, first_p_pos, local_leading_dimension, template_fmstruct, square_blocks, force_block)
allocates and initializes a full matrix structure
Definition cp_fm_struct.F:132
cp_fm_struct::cp_fm_struct_release
subroutine, public cp_fm_struct_release(fmstruct)
releases a full matrix structure
Definition cp_fm_struct.F:351
cp_fm_types
represent a full matrix distributed on many processors
Definition cp_fm_types.F:15
cp_fm_types::cp_fm_get_info
subroutine, public cp_fm_get_info(matrix, name, nrow_global, ncol_global, nrow_block, ncol_block, nrow_local, ncol_local, row_indices, col_indices, local_data, context, nrow_locals, ncol_locals, matrix_struct, para_env)
returns all kind of information about the full matrix
Definition cp_fm_types.F:1037
cp_fm_types::cp_fm_create
subroutine, public cp_fm_create(matrix, matrix_struct, name, nrow, ncol, set_zero)
creates a new full matrix with the given structure
Definition cp_fm_types.F:165
distribution_2d_types
stores a mapping of 2D info (e.g. matrix) on a 2D processor distribution (i.e. blacs grid) where cpus...
Definition distribution_2d_types.F:15
distribution_2d_types::distribution_2d_get
subroutine, public distribution_2d_get(distribution_2d, row_distribution, col_distribution, n_row_distribution, n_col_distribution, n_local_rows, n_local_cols, local_rows, local_cols, flat_local_rows, flat_local_cols, n_flat_local_rows, n_flat_local_cols, blacs_env)
returns various attributes about the distribution_2d
Definition distribution_2d_types.F:481
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
kinds::default_string_length
integer, parameter, public default_string_length
Definition kinds.F:57
mathlib
Collection of simple mathematical functions and subroutines.
Definition mathlib.F:15
mathlib::lcm
elemental integer function, public lcm(a, b)
computes the least common multiplier of two numbers
Definition mathlib.F:1322
mathlib::gcd
elemental integer function, public gcd(a, b)
computes the greatest common divisor of two number
Definition mathlib.F:1287
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
cp_blacs_env::cp_blacs_env_type
represent a blacs multidimensional parallel environment (for the mpi corrispective see cp_paratypes/m...
Definition cp_blacs_env.F:53
cp_dbcsr_api::dbcsr_distribution_type
Definition cp_dbcsr_api.F:182
cp_dbcsr_api::dbcsr_iterator_type
Definition cp_dbcsr_api.F:188
cp_dbcsr_api::dbcsr_p_type
Definition cp_dbcsr_api.F:172
cp_dbcsr_api::dbcsr_type
Definition cp_dbcsr_api.F:176
cp_fm_struct::cp_fm_struct_type
keeps the information about the structure of a full matrix
Definition cp_fm_struct.F:82
cp_fm_types::cp_fm_type
represent a full matrix
Definition cp_fm_types.F:114
distribution_2d_types::distribution_2d_type
distributes pairs on a 2d grid of processors
Definition distribution_2d_types.F:62
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:743