(git:b6ef100)
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) THEN
615 CALL copy_fm_to_dbcsr(fm_out, out)
616 END IF
617
618 CALL timeset(routinen//'_core', timing_handle_mult)
619 CALL dbcsr_multiply("N", "N", my_alpha, matrix, in, my_beta, out, &
620 last_column=ncol)
621 CALL timestop(timing_handle_mult)
622
623 CALL copy_dbcsr_to_fm(out, fm_out)
624
625 CALL dbcsr_release(in)
626 CALL dbcsr_release(out)
627 DEALLOCATE (col_blk_size_right_in, col_blk_size_right_out)
628 CALL dbcsr_distribution_release(dist_right_in)
629 CALL dbcsr_distribution_release(product_dist)
630
631 END IF
632
633 CALL timestop(timing_handle)
634
635 END SUBROUTINE cp_dbcsr_sm_fm_multiply
636
637! **************************************************************************************************
638!> \brief ...
639!> \param sizes1 ...
640!> \param sizes2 ...
641!> \param full_num ...
642! **************************************************************************************************
643 SUBROUTINE match_col_sizes(sizes1, sizes2, full_num)
644 INTEGER, DIMENSION(:), INTENT(INOUT) :: sizes1
645 INTEGER, DIMENSION(:), INTENT(IN) :: sizes2
646 INTEGER, INTENT(IN) :: full_num
647
648 INTEGER :: left, n1, n2, p, rm, used
649
650 n1 = SIZE(sizes1)
651 n2 = SIZE(sizes2)
652 IF (n1 /= n2) THEN
653 cpabort("distributions must be equal!")
654 END IF
655 sizes1(1:n1) = sizes2(1:n1)
656 used = sum(sizes1(1:n1))
657 ! If sizes1 does not cover everything, then we increase the
658 ! size of the last block; otherwise we reduce the blocks
659 ! (from the end) until it is small enough.
660 IF (used < full_num) THEN
661 sizes1(n1) = sizes1(n1) + full_num - used
662 ELSE
663 left = used - full_num
664 p = n1
665 DO WHILE (left > 0 .AND. p > 0)
666 rm = min(left, sizes1(p))
667 sizes1(p) = sizes1(p) - rm
668 left = left - rm
669 p = p - 1
670 END DO
671 END IF
672 END SUBROUTINE match_col_sizes
673
674! **************************************************************************************************
675!> \brief performs the multiplication sparse_matrix+dense_mat*dens_mat^T
676!> if matrix_g is not explicitly given, matrix_v^T will be used
677!> this can be important to save the necessary redistribute for a
678!> different matrix_g and increase performance.
679!> \param sparse_matrix ...
680!> \param matrix_v ...
681!> \param matrix_g ...
682!> \param ncol ...
683!> \param alpha ...
684!> \param keep_sparsity Determines if the sparsity of sparse_matrix is retained
685!> by default it is TRUE
686!> \param symmetry_mode There are the following modes
687!> 1: sparse_matrix += 0.5*alpha*(v*g^T+g^T*v) (symmetric update)
688!> -1: sparse_matrix += 0.5*alpha*(v*g^T-g^T*v) (skewsymmetric update)
689!> else: sparse_matrix += alpha*v*g^T (no symmetry, default)
690!> saves some redistribution steps
691! **************************************************************************************************
692 SUBROUTINE cp_dbcsr_plus_fm_fm_t(sparse_matrix, matrix_v, matrix_g, ncol, alpha, keep_sparsity, symmetry_mode)
693 TYPE(dbcsr_type), INTENT(INOUT) :: sparse_matrix
694 TYPE(cp_fm_type), INTENT(IN) :: matrix_v
695 TYPE(cp_fm_type), INTENT(IN), OPTIONAL :: matrix_g
696 INTEGER, INTENT(IN) :: ncol
697 REAL(kind=dp), INTENT(IN), OPTIONAL :: alpha
698 LOGICAL, INTENT(IN), OPTIONAL :: keep_sparsity
699 INTEGER, INTENT(IN), OPTIONAL :: symmetry_mode
700
701 CHARACTER(LEN=*), PARAMETER :: routinen = 'cp_dbcsr_plus_fm_fm_t'
702
703 INTEGER :: k, my_symmetry_mode, nao, npcols, &
704 timing_handle
705 INTEGER, DIMENSION(:), POINTER :: col_blk_size_left, col_dist_left, &
706 row_blk_size, row_dist
707 LOGICAL :: check_product, my_keep_sparsity
708 REAL(kind=dp) :: my_alpha, norm
709 TYPE(cp_fm_struct_type), POINTER :: fm_struct_tmp
710 TYPE(cp_fm_type) :: fm_matrix
711 TYPE(dbcsr_distribution_type) :: dist_left, sparse_dist
712 TYPE(dbcsr_type) :: mat_g, mat_v, sparse_matrix2, &
713 sparse_matrix3
714
715 check_product = .false.
716
717 CALL timeset(routinen, timing_handle)
718
719 my_keep_sparsity = .true.
720 IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity
721
722 my_symmetry_mode = 0
723 IF (PRESENT(symmetry_mode)) my_symmetry_mode = symmetry_mode
724
725 NULLIFY (col_dist_left)
726
727 IF (ncol > 0) THEN
728 IF (.NOT. dbcsr_valid_index(sparse_matrix)) THEN
729 cpabort("sparse_matrix must pre-exist")
730 END IF
731 !
732 ! Setup matrix_v
733 CALL cp_fm_get_info(matrix_v, ncol_global=k)
734 !WRITE(*,*)routineN//'truncated mult k, ncol',k,ncol,' PRESENT (matrix_g)',PRESENT (matrix_g)
735 CALL dbcsr_get_info(sparse_matrix, distribution=sparse_dist)
736 CALL dbcsr_distribution_get(sparse_dist, npcols=npcols, row_dist=row_dist)
737 CALL create_bl_distribution(col_dist_left, col_blk_size_left, k, npcols)
738 CALL dbcsr_distribution_new(dist_left, template=sparse_dist, &
739 row_dist=row_dist, col_dist=col_dist_left)
740 DEALLOCATE (col_dist_left)
741 CALL dbcsr_get_info(sparse_matrix, row_blk_size=row_blk_size)
742 CALL dbcsr_create(mat_v, "DBCSR matrix_v", dist_left, dbcsr_type_no_symmetry, &
743 row_blk_size, col_blk_size_left)
744 CALL copy_fm_to_dbcsr(matrix_v, mat_v)
745 CALL dbcsr_verify_matrix(mat_v)
746 !
747 ! Setup matrix_g
748 IF (PRESENT(matrix_g)) THEN
749 CALL dbcsr_create(mat_g, "DBCSR matrix_g", dist_left, dbcsr_type_no_symmetry, &
750 row_blk_size, col_blk_size_left)
751 CALL copy_fm_to_dbcsr(matrix_g, mat_g)
752 END IF
753 !
754 DEALLOCATE (col_blk_size_left)
755 CALL dbcsr_distribution_release(dist_left)
756 !
757 !
758 IF (check_product) THEN
759 CALL cp_fm_get_info(matrix_v, nrow_global=nao)
760 CALL cp_fm_struct_create(fm_struct_tmp, context=matrix_v%matrix_struct%context, nrow_global=nao, &
761 ncol_global=nao, para_env=matrix_v%matrix_struct%para_env)
762 CALL cp_fm_create(fm_matrix, fm_struct_tmp, name="fm matrix")
763 CALL cp_fm_struct_release(fm_struct_tmp)
764 CALL copy_dbcsr_to_fm(sparse_matrix, fm_matrix)
765 CALL dbcsr_copy(sparse_matrix3, sparse_matrix)
766 END IF
767 !
768 my_alpha = 1.0_dp
769 IF (PRESENT(alpha)) my_alpha = alpha
770 IF (PRESENT(matrix_g)) THEN
771 IF (my_symmetry_mode == 1) THEN
772 ! Symmetric mode
773 CALL dbcsr_multiply("N", "T", 0.5_dp*my_alpha, mat_v, mat_g, &
774 1.0_dp, sparse_matrix, &
775 retain_sparsity=my_keep_sparsity, &
776 last_k=ncol)
777 CALL dbcsr_multiply("N", "T", 0.5_dp*my_alpha, mat_g, mat_v, &
778 1.0_dp, sparse_matrix, &
779 retain_sparsity=my_keep_sparsity, &
780 last_k=ncol)
781 ELSE IF (my_symmetry_mode == -1) THEN
782 ! Skewsymmetric mode
783 CALL dbcsr_multiply("N", "T", 0.5_dp*my_alpha, mat_v, mat_g, &
784 1.0_dp, sparse_matrix, &
785 retain_sparsity=my_keep_sparsity, &
786 last_k=ncol)
787 CALL dbcsr_multiply("N", "T", -0.5_dp*my_alpha, mat_g, mat_v, &
788 1.0_dp, sparse_matrix, &
789 retain_sparsity=my_keep_sparsity, &
790 last_k=ncol)
791 ELSE
792 ! Normal mode
793 CALL dbcsr_multiply("N", "T", my_alpha, mat_v, mat_g, &
794 1.0_dp, sparse_matrix, &
795 retain_sparsity=my_keep_sparsity, &
796 last_k=ncol)
797 END IF
798 ELSE
799 CALL dbcsr_multiply("N", "T", my_alpha, mat_v, mat_v, &
800 1.0_dp, sparse_matrix, &
801 retain_sparsity=my_keep_sparsity, &
802 last_k=ncol)
803 END IF
804
805 IF (check_product) THEN
806 IF (PRESENT(matrix_g)) THEN
807 IF (my_symmetry_mode == 1) THEN
808 CALL cp_fm_gemm("N", "T", nao, nao, ncol, 0.5_dp*my_alpha, matrix_v, matrix_g, &
809 1.0_dp, fm_matrix)
810 CALL cp_fm_gemm("N", "T", nao, nao, ncol, 0.5_dp*my_alpha, matrix_g, matrix_v, &
811 1.0_dp, fm_matrix)
812 ELSE IF (my_symmetry_mode == -1) THEN
813 CALL cp_fm_gemm("N", "T", nao, nao, ncol, 0.5_dp*my_alpha, matrix_v, matrix_g, &
814 1.0_dp, fm_matrix)
815 CALL cp_fm_gemm("N", "T", nao, nao, ncol, -0.5_dp*my_alpha, matrix_g, matrix_v, &
816 1.0_dp, fm_matrix)
817 ELSE
818 CALL cp_fm_gemm("N", "T", nao, nao, ncol, my_alpha, matrix_v, matrix_g, &
819 1.0_dp, fm_matrix)
820 END IF
821 ELSE
822 CALL cp_fm_gemm("N", "T", nao, nao, ncol, my_alpha, matrix_v, matrix_v, &
823 1.0_dp, fm_matrix)
824 END IF
825
826 CALL dbcsr_copy(sparse_matrix2, sparse_matrix)
827 CALL dbcsr_scale(sparse_matrix2, alpha_scalar=0.0_dp)
828 CALL copy_fm_to_dbcsr(fm_matrix, sparse_matrix2, keep_sparsity=my_keep_sparsity)
829 CALL dbcsr_add(sparse_matrix2, sparse_matrix, alpha_scalar=1.0_dp, &
830 beta_scalar=-1.0_dp)
831 norm = dbcsr_frobenius_norm(sparse_matrix2)
832 WRITE (*, *) 'nao=', nao, ' k=', k, ' ncol=', ncol, ' my_alpha=', my_alpha
833 WRITE (*, *) 'PRESENT (matrix_g)', PRESENT(matrix_g)
834 WRITE (*, *) 'matrix_type=', dbcsr_get_matrix_type(sparse_matrix)
835 WRITE (*, *) 'norm(sm+alpha*v*g^t - fm+alpha*v*g^t)/n=', norm/real(nao, dp)
836 CALL dbcsr_release(sparse_matrix2)
837 CALL dbcsr_release(sparse_matrix3)
838 CALL cp_fm_release(fm_matrix)
839 END IF
840 CALL dbcsr_release(mat_v)
841 IF (PRESENT(matrix_g)) CALL dbcsr_release(mat_g)
842 END IF
843 CALL timestop(timing_handle)
844
845 END SUBROUTINE cp_dbcsr_plus_fm_fm_t
846
847! **************************************************************************************************
848!> \brief Utility function to copy a specially shaped fm to dbcsr_matrix
849!> The result matrix will be the matrix in dbcsr format
850!> with the row blocks sizes according to the block_sizes of the template
851!> and the col blocks sizes evenly blocked with the internal dbcsr conversion
852!> size (32 is the current default)
853!> \param matrix ...
854!> \param fm_in ...
855!> \param template ...
856! **************************************************************************************************
857 SUBROUTINE cp_fm_to_dbcsr_row_template(matrix, fm_in, template)
858 TYPE(dbcsr_type), INTENT(INOUT) :: matrix
859 TYPE(cp_fm_type), INTENT(IN) :: fm_in
860 TYPE(dbcsr_type), INTENT(IN) :: template
861
862 INTEGER :: k_in
863 INTEGER, DIMENSION(:), POINTER :: col_blk_size_right_in, row_blk_size
864 TYPE(dbcsr_distribution_type) :: dist_right_in, tmpl_dist
865
866 CALL cp_fm_get_info(fm_in, ncol_global=k_in)
867
868 CALL dbcsr_get_info(template, distribution=tmpl_dist)
869 CALL dbcsr_create_dist_r_unrot(dist_right_in, tmpl_dist, k_in, col_blk_size_right_in)
870 CALL dbcsr_get_info(template, row_blk_size=row_blk_size)
871 CALL dbcsr_create(matrix, "D", dist_right_in, dbcsr_type_no_symmetry, &
872 row_blk_size, col_blk_size_right_in)
873
874 CALL copy_fm_to_dbcsr(fm_in, matrix)
875 DEALLOCATE (col_blk_size_right_in)
876 CALL dbcsr_distribution_release(dist_right_in)
877
878 END SUBROUTINE cp_fm_to_dbcsr_row_template
879
880! **************************************************************************************************
881!> \brief Utility function to create an arbitrary shaped dbcsr matrix
882!> with the same processor grid as the template matrix
883!> both row sizes and col sizes are evenly blocked with the internal
884!> dbcsr_conversion size (32 is the current default)
885!> \param matrix dbcsr matrix to be created
886!> \param template template dbcsr matrix giving its mp_env
887!> \param m global row size of output matrix
888!> \param n global col size of output matrix
889!> \param sym ...
890! **************************************************************************************************
891 SUBROUTINE cp_dbcsr_m_by_n_from_template(matrix, template, m, n, sym)
892 TYPE(dbcsr_type), INTENT(INOUT) :: matrix, template
893 INTEGER, INTENT(IN) :: m, n
894 CHARACTER, INTENT(IN), OPTIONAL :: sym
895
896 CHARACTER :: mysym
897 INTEGER :: npcols, nprows
898 INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_dist, row_blk_size, &
899 row_dist
900 TYPE(dbcsr_distribution_type) :: dist_m_n, tmpl_dist
901
902 CALL dbcsr_get_info(template, matrix_type=mysym, distribution=tmpl_dist)
903
904 IF (PRESENT(sym)) mysym = sym
905
906 NULLIFY (row_dist, col_dist)
907 NULLIFY (row_blk_size, col_blk_size)
908 !NULLIFY (row_cluster, col_cluster)
909
910 CALL dbcsr_distribution_get(tmpl_dist, nprows=nprows, npcols=npcols)
911 CALL create_bl_distribution(row_dist, row_blk_size, m, nprows)
912 CALL create_bl_distribution(col_dist, col_blk_size, n, npcols)
913 CALL dbcsr_distribution_new(dist_m_n, template=tmpl_dist, &
914 row_dist=row_dist, col_dist=col_dist, &
915 !row_cluster=row_cluster, col_cluster=col_cluster, &
916 reuse_arrays=.true.)
917
918 CALL dbcsr_create(matrix, "m_n_template", dist_m_n, mysym, &
919 row_blk_size, col_blk_size, reuse_arrays=.true.)
920 CALL dbcsr_distribution_release(dist_m_n)
921
922 END SUBROUTINE cp_dbcsr_m_by_n_from_template
923
924! **************************************************************************************************
925!> \brief Utility function to create dbcsr matrix, m x n matrix (n arbitrary)
926!> with the same processor grid and row distribution as the template matrix
927!> col sizes are evenly blocked with the internal
928!> dbcsr_conversion size (32 is the current default)
929!> \param matrix dbcsr matrix to be created
930!> \param template template dbcsr matrix giving its mp_env
931!> \param n global col size of output matrix
932!> \param sym ...
933! **************************************************************************************************
934 SUBROUTINE cp_dbcsr_m_by_n_from_row_template(matrix, template, n, sym)
935 TYPE(dbcsr_type), INTENT(INOUT) :: matrix, template
936 INTEGER :: n
937 CHARACTER, OPTIONAL :: sym
938
939 CHARACTER :: mysym
940 INTEGER :: npcols
941 INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_dist, row_blk_size, &
942 row_dist
943 TYPE(dbcsr_distribution_type) :: dist_m_n, tmpl_dist
944
945 mysym = dbcsr_get_matrix_type(template)
946 IF (PRESENT(sym)) mysym = sym
947
948 CALL dbcsr_get_info(template, distribution=tmpl_dist)
949 CALL dbcsr_distribution_get(tmpl_dist, &
950 npcols=npcols, &
951 row_dist=row_dist)
952
953 NULLIFY (col_dist, col_blk_size)
954 CALL create_bl_distribution(col_dist, col_blk_size, n, npcols)
955 CALL dbcsr_distribution_new(dist_m_n, template=tmpl_dist, &
956 row_dist=row_dist, col_dist=col_dist)
957
958 CALL dbcsr_get_info(template, row_blk_size=row_blk_size)
959 CALL dbcsr_create(matrix, "m_n_template", dist_m_n, mysym, row_blk_size, col_blk_size)
960
961 DEALLOCATE (col_dist, col_blk_size)
962 CALL dbcsr_distribution_release(dist_m_n)
963
964 END SUBROUTINE cp_dbcsr_m_by_n_from_row_template
965
966! **************************************************************************************************
967!> \brief Distributes elements into blocks and into bins
968!>
969!> \param[out] block_distribution block distribution to bins
970!> \param[out] block_size sizes of blocks
971!> \param[in] nelements number of elements to bin
972!> \param[in] nbins number of bins
973!> \par Term clarification
974!> An example: blocks are atom blocks and bins are process rows/columns.
975! **************************************************************************************************
976 SUBROUTINE create_bl_distribution(block_distribution, &
977 block_size, nelements, nbins)
978 INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: block_distribution, block_size
979 INTEGER, INTENT(IN) :: nelements, nbins
980
981 CHARACTER(len=*), PARAMETER :: routinen = 'create_bl_distribution', &
982 routinep = modulen//':'//routinen
983
984 INTEGER :: bin, blk_layer, element_stack, els, &
985 estimated_blocks, max_blocks_per_bin, &
986 nblks, nblocks, stat
987 INTEGER, DIMENSION(:), POINTER :: blk_dist, blk_sizes
988
989! ---------------------------------------------------------------------------
990
991 NULLIFY (block_distribution)
992 NULLIFY (block_size)
993 ! Define the sizes on which we build the distribution.
994 IF (nelements > 0) THEN
995
996 nblocks = ceiling(real(nelements, kind=dp)/real(max_elements_per_block, kind=dp))
997 max_blocks_per_bin = ceiling(real(nblocks, kind=dp)/real(nbins, kind=dp))
998
999 IF (debug_mod) THEN
1000 WRITE (*, '(1X,A,1X,A,I7,A,I7,A)') routinep, "For", nelements, &
1001 " elements and", nbins, " bins"
1002 WRITE (*, '(1X,A,1X,A,I7,A)') routinep, "There are", &
1003 max_elements_per_block, " max elements per block"
1004 WRITE (*, '(1X,A,1X,A,I7,A)') routinep, "There are", &
1005 nblocks, " blocks"
1006 WRITE (*, '(1X,A,1X,A,I7,A)') routinep, "There are", &
1007 max_blocks_per_bin, " max blocks/bin"
1008 END IF
1009
1010 estimated_blocks = max_blocks_per_bin*nbins
1011 ALLOCATE (blk_dist(estimated_blocks), stat=stat)
1012 IF (stat /= 0) THEN
1013 cpabort("blk_dist")
1014 END IF
1015 ALLOCATE (blk_sizes(estimated_blocks), stat=stat)
1016 IF (stat /= 0) THEN
1017 cpabort("blk_sizes")
1018 END IF
1019 element_stack = 0
1020 nblks = 0
1021 DO blk_layer = 1, max_blocks_per_bin
1022 DO bin = 0, nbins - 1
1023 els = min(max_elements_per_block, nelements - element_stack)
1024 IF (els > 0) THEN
1025 element_stack = element_stack + els
1026 nblks = nblks + 1
1027 blk_dist(nblks) = bin
1028 blk_sizes(nblks) = els
1029 IF (debug_mod) WRITE (*, '(1X,A,I5,A,I5,A,I5)') routinep//" Assigning", &
1030 els, " elements as block", nblks, " to bin", bin
1031 END IF
1032 END DO
1033 END DO
1034 ! Create the output arrays.
1035 IF (nblks == estimated_blocks) THEN
1036 block_distribution => blk_dist
1037 block_size => blk_sizes
1038 ELSE
1039 ALLOCATE (block_distribution(nblks), stat=stat)
1040 IF (stat /= 0) THEN
1041 cpabort("blk_dist")
1042 END IF
1043 block_distribution(:) = blk_dist(1:nblks)
1044 DEALLOCATE (blk_dist)
1045 ALLOCATE (block_size(nblks), stat=stat)
1046 IF (stat /= 0) THEN
1047 cpabort("blk_sizes")
1048 END IF
1049 block_size(:) = blk_sizes(1:nblks)
1050 DEALLOCATE (blk_sizes)
1051 END IF
1052 ELSE
1053 ALLOCATE (block_distribution(0), stat=stat)
1054 IF (stat /= 0) THEN
1055 cpabort("blk_dist")
1056 END IF
1057 ALLOCATE (block_size(0), stat=stat)
1058 IF (stat /= 0) THEN
1059 cpabort("blk_sizes")
1060 END IF
1061 END IF
10621579 FORMAT(i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5, 1x, i5)
1063 IF (debug_mod) THEN
1064 WRITE (*, '(1X,A,A)') routinep//" Distribution"
1065 WRITE (*, 1579) block_distribution(:)
1066 WRITE (*, '(1X,A,A)') routinep//" Sizes"
1067 WRITE (*, 1579) block_size(:)
1068 END IF
1069 END SUBROUTINE create_bl_distribution
1070
1071! **************************************************************************************************
1072!> \brief Creates a new distribution for the right matrix in a matrix
1073!> multiplication with unrotated grid.
1074!> \param[out] dist_right new distribution for the right matrix
1075!> \param[in] dist_left the distribution of the left matrix
1076!> \param[in] ncolumns number of columns in right matrix
1077!> \param[out] right_col_blk_sizes sizes of blocks in the created column
1078!> \par The new row distribution for the right matrix is the same as the row
1079!> distribution of the left matrix, while the column distribution is
1080!> created so that it is appropriate to the parallel environment.
1081! **************************************************************************************************
1082 SUBROUTINE dbcsr_create_dist_r_unrot(dist_right, dist_left, ncolumns, &
1083 right_col_blk_sizes)
1084 TYPE(dbcsr_distribution_type), INTENT(OUT) :: dist_right
1085 TYPE(dbcsr_distribution_type), INTENT(IN) :: dist_left
1086 INTEGER, INTENT(IN) :: ncolumns
1087 INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: right_col_blk_sizes
1088
1089 INTEGER :: multiplicity, ncols, nimages, npcols, &
1090 nprows
1091 INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_images
1092 INTEGER, DIMENSION(:), POINTER :: old_col_dist, right_col_dist, &
1093 right_row_dist
1094
1095 CALL dbcsr_distribution_get(dist_left, &
1096 ncols=ncols, &
1097 col_dist=old_col_dist, &
1098 nprows=nprows, &
1099 npcols=npcols)
1100
1101 ! Create the column distribution
1102 CALL create_bl_distribution(right_col_dist, right_col_blk_sizes, ncolumns, npcols)
1103 ! Create an even row distribution.
1104 ALLOCATE (right_row_dist(ncols), tmp_images(ncols))
1105 nimages = lcm(nprows, npcols)/nprows
1106 multiplicity = nprows/gcd(nprows, npcols)
1107 CALL rebin_distribution(right_row_dist, tmp_images, old_col_dist, nprows, multiplicity, nimages)
1108
1109 CALL dbcsr_distribution_new(dist_right, &
1110 template=dist_left, &
1111 row_dist=right_row_dist, &
1112 col_dist=right_col_dist, &
1113 !row_cluster=dummy,&
1114 !col_cluster=dummy,&
1115 reuse_arrays=.true.)
1116 DEALLOCATE (tmp_images)
1117 END SUBROUTINE dbcsr_create_dist_r_unrot
1118
1119! **************************************************************************************************
1120!> \brief Makes new distribution with decimation and multiplicity
1121!> \param[out] new_bins new real distribution
1122!> \param[out] images new image distribution
1123!> \param[in] source_bins Basis for the new distribution and images
1124!> \param[in] nbins number of bins in the new real distribution
1125!> \param[in] multiplicity multiplicity
1126!> \param[in] nimages number of images in the new distribution
1127!> \par Definition of multiplicity and nimages
1128!> Multiplicity and decimation (number of images) are used to
1129!> match process grid coordinates on non-square process
1130!> grids. Given source_nbins and target_nbins, their relation is
1131!> source_nbins * target_multiplicity
1132!> = target_nbins * target_nimages.
1133!> It is best when both multiplicity and nimages are small. To
1134!> get these two factors, then, one can use the following formulas:
1135!> nimages = lcm(source_nbins, target_nbins) / target_nbins
1136!> multiplicity = target_nbins / gcd(source_nbins, target_nbins)
1137!> from the target's point of view (nimages = target_nimages).
1138!> \par Mapping
1139!> The new distribution comprises of real bins and images within
1140!> bins. These can be view as target_nbins*nimages virtual
1141!> columns. These same virtual columns are also
1142!> source_nbins*multiplicity in number. Therefore these virtual
1143!> columns are mapped from source_nbins*multiplicity onto
1144!> target_bins*nimages (each target bin has nimages images):
1145!> Source 4: |1 2 3|4 5 6|7 8 9|A B C| (4*3)
1146!> Target 6: |1 2|3 4|5 6|7 8|9 A|B C| (6*2)
1147!> multiplicity=3, nimages=2, 12 virtual columns (1-C).
1148!> Source bin elements are evenly mapped into one of multiplicity
1149!> virtual columns. Other (non-even, block-size aware) mappings
1150!> could be better.
1151! **************************************************************************************************
1152 SUBROUTINE rebin_distribution(new_bins, images, source_bins, &
1153 nbins, multiplicity, nimages)
1154 INTEGER, DIMENSION(:), INTENT(OUT) :: new_bins, images
1155 INTEGER, DIMENSION(:), INTENT(IN) :: source_bins
1156 INTEGER, INTENT(IN) :: nbins, multiplicity, nimages
1157
1158 INTEGER :: bin, i, old_nbins, virtual_bin
1159 INTEGER, ALLOCATABLE, DIMENSION(:) :: bin_multiplier
1160
1161! ---------------------------------------------------------------------------
1162
1163 IF (mod(nbins*nimages, multiplicity) /= 0) THEN
1164 cpwarn("mulitplicity is not divisor of new process grid coordinate")
1165 END IF
1166 old_nbins = (nbins*nimages)/multiplicity
1167 ALLOCATE (bin_multiplier(0:old_nbins - 1))
1168 bin_multiplier(:) = 0
1169 DO i = 1, SIZE(new_bins)
1170 IF (i <= SIZE(source_bins)) THEN
1171 bin = source_bins(i)
1172 ELSE
1173 ! Fill remainder with a cyclic distribution
1174 bin = mod(i, old_nbins)
1175 END IF
1176 virtual_bin = bin*multiplicity + bin_multiplier(bin)
1177 new_bins(i) = virtual_bin/nimages
1178 images(i) = 1 + mod(virtual_bin, nimages)
1179 bin_multiplier(bin) = bin_multiplier(bin) + 1
1180 IF (bin_multiplier(bin) >= multiplicity) THEN
1181 bin_multiplier(bin) = 0
1182 END IF
1183 END DO
1184 END SUBROUTINE rebin_distribution
1185
1186! **************************************************************************************************
1187!> \brief Creates a block-cyclic compatible distribution
1188!>
1189!> All blocks in a dimension, except for possibly the last
1190!> block, have the same size.
1191!> \param[out] dist the elemental distribution
1192!> \param[in] nrows number of full rows
1193!> \param[in] ncolumns number of full columns
1194!> \param[in] nrow_block size of row blocks
1195!> \param[in] ncol_block size of column blocks
1196!> \param group_handle ...
1197!> \param pgrid ...
1198!> \param[out] row_blk_sizes row block sizes
1199!> \param[out] col_blk_sizes column block sizes
1200! **************************************************************************************************
1201 SUBROUTINE dbcsr_create_dist_block_cyclic(dist, nrows, ncolumns, &
1202 nrow_block, ncol_block, group_handle, pgrid, row_blk_sizes, col_blk_sizes)
1203 TYPE(dbcsr_distribution_type), INTENT(OUT) :: dist
1204 INTEGER, INTENT(IN) :: nrows, ncolumns, nrow_block, ncol_block, &
1205 group_handle
1206 INTEGER, DIMENSION(:, :), POINTER :: pgrid
1207 INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: row_blk_sizes, col_blk_sizes
1208
1209 CHARACTER(len=*), PARAMETER :: routinen = 'dbcsr_create_dist_block_cyclic'
1210
1211 INTEGER :: nblkcols, nblkrows, npcols, nprows, &
1212 pdim, sz
1213 INTEGER, DIMENSION(:), POINTER :: cd_data, rd_data
1214
1215 ! Row sizes
1216 IF (nrow_block == 0) THEN
1217 nblkrows = 0
1218 sz = 0
1219 ELSE
1220 nblkrows = nrows/nrow_block
1221 sz = mod(nrows, nrow_block)
1222 END IF
1223 IF (sz > 0) nblkrows = nblkrows + 1
1224 ALLOCATE (row_blk_sizes(nblkrows), rd_data(nblkrows))
1225 row_blk_sizes = nrow_block
1226 IF (sz /= 0) row_blk_sizes(nblkrows) = sz
1227
1228 ! Column sizes
1229 IF (ncol_block == 0) THEN
1230 nblkcols = 0
1231 sz = 0
1232 ELSE
1233 nblkcols = ncolumns/ncol_block
1234 sz = mod(ncolumns, ncol_block)
1235 END IF
1236 IF (sz > 0) nblkcols = nblkcols + 1
1237 ALLOCATE (col_blk_sizes(nblkcols), cd_data(nblkcols))
1238 col_blk_sizes = ncol_block
1239 IF (sz /= 0) col_blk_sizes(nblkcols) = sz
1240 !
1241 IF (debug_mod) THEN
1242 WRITE (*, *) routinen//" nrows,nrow_block,nblkrows=", &
1243 nrows, nrow_block, nblkrows
1244 WRITE (*, *) routinen//" ncols,ncol_block,nblkcols=", &
1245 ncolumns, ncol_block, nblkcols
1246 END IF
1247 ! Calculate process row distribution
1248 nprows = SIZE(pgrid, 1)
1249 DO pdim = 0, min(nprows - 1, nblkrows - 1)
1250 rd_data(1 + pdim:nblkrows:nprows) = pdim
1251 END DO
1252 ! Calculate process column distribution
1253 npcols = SIZE(pgrid, 2)
1254 DO pdim = 0, min(npcols - 1, nblkcols - 1)
1255 cd_data(1 + pdim:nblkcols:npcols) = pdim
1256 END DO
1257 !
1258 IF (debug_mod) THEN
1259 WRITE (*, *) routinen//" row_dist", &
1260 rd_data
1261 WRITE (*, *) routinen//" col_dist", &
1262 cd_data
1263 END IF
1264 !
1265 CALL dbcsr_distribution_new(dist, &
1266 group=group_handle, pgrid=pgrid, &
1267 row_dist=rd_data, &
1268 col_dist=cd_data, &
1269 reuse_arrays=.true.)
1270
1271 END SUBROUTINE dbcsr_create_dist_block_cyclic
1272
1273! **************************************************************************************************
1274!> \brief Allocate and initialize a real matrix 1-dimensional set.
1275!> \param[in,out] matrix_set Set containing the DBCSR matrices
1276!> \param[in] nmatrix Size of set
1277!> \par History
1278!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1279! **************************************************************************************************
1280 SUBROUTINE allocate_dbcsr_matrix_set_1d(matrix_set, nmatrix)
1281 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_set
1282 INTEGER, INTENT(IN) :: nmatrix
1283
1284 INTEGER :: imatrix
1285
1286 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1287 ALLOCATE (matrix_set(nmatrix))
1288 DO imatrix = 1, nmatrix
1289 NULLIFY (matrix_set(imatrix)%matrix)
1290 END DO
1291 END SUBROUTINE allocate_dbcsr_matrix_set_1d
1292
1293! **************************************************************************************************
1294!> \brief Allocate and initialize a real matrix 2-dimensional set.
1295!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1296!> \param[in] nmatrix Size of set
1297!> \param mmatrix ...
1298!> \par History
1299!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1300! **************************************************************************************************
1301 SUBROUTINE allocate_dbcsr_matrix_set_2d(matrix_set, nmatrix, mmatrix)
1302 TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_set
1303 INTEGER, INTENT(IN) :: nmatrix, mmatrix
1304
1305 INTEGER :: imatrix, jmatrix
1306
1307 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1308 ALLOCATE (matrix_set(nmatrix, mmatrix))
1309 DO jmatrix = 1, mmatrix
1310 DO imatrix = 1, nmatrix
1311 NULLIFY (matrix_set(imatrix, jmatrix)%matrix)
1312 END DO
1313 END DO
1314 END SUBROUTINE allocate_dbcsr_matrix_set_2d
1315
1316! **************************************************************************************************
1317!> \brief Allocate and initialize a real matrix 3-dimensional set.
1318!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1319!> \param[in] nmatrix Size of set
1320!> \param mmatrix ...
1321!> \param pmatrix ...
1322!> \par History
1323!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1324! **************************************************************************************************
1325 SUBROUTINE allocate_dbcsr_matrix_set_3d(matrix_set, nmatrix, mmatrix, pmatrix)
1326 TYPE(dbcsr_p_type), DIMENSION(:, :, :), POINTER :: matrix_set
1327 INTEGER, INTENT(IN) :: nmatrix, mmatrix, pmatrix
1328
1329 INTEGER :: imatrix, jmatrix, kmatrix
1330
1331 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1332 ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix))
1333 DO kmatrix = 1, pmatrix
1334 DO jmatrix = 1, mmatrix
1335 DO imatrix = 1, nmatrix
1336 NULLIFY (matrix_set(imatrix, jmatrix, kmatrix)%matrix)
1337 END DO
1338 END DO
1339 END DO
1340 END SUBROUTINE allocate_dbcsr_matrix_set_3d
1341
1342! **************************************************************************************************
1343!> \brief Allocate and initialize a real matrix 4-dimensional set.
1344!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1345!> \param[in] nmatrix Size of set
1346!> \param mmatrix ...
1347!> \param pmatrix ...
1348!> \param qmatrix ...
1349!> \par History
1350!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1351! **************************************************************************************************
1352 SUBROUTINE allocate_dbcsr_matrix_set_4d(matrix_set, nmatrix, mmatrix, pmatrix, qmatrix)
1353 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :), POINTER :: matrix_set
1354 INTEGER, INTENT(IN) :: nmatrix, mmatrix, pmatrix, qmatrix
1355
1356 INTEGER :: imatrix, jmatrix, kmatrix, lmatrix
1357
1358 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1359 ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix, qmatrix))
1360 DO lmatrix = 1, qmatrix
1361 DO kmatrix = 1, pmatrix
1362 DO jmatrix = 1, mmatrix
1363 DO imatrix = 1, nmatrix
1364 NULLIFY (matrix_set(imatrix, jmatrix, kmatrix, lmatrix)%matrix)
1365 END DO
1366 END DO
1367 END DO
1368 END DO
1369 END SUBROUTINE allocate_dbcsr_matrix_set_4d
1370
1371! **************************************************************************************************
1372!> \brief Allocate and initialize a real matrix 5-dimensional set.
1373!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1374!> \param[in] nmatrix Size of set
1375!> \param mmatrix ...
1376!> \param pmatrix ...
1377!> \param qmatrix ...
1378!> \param smatrix ...
1379!> \par History
1380!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1381! **************************************************************************************************
1382 SUBROUTINE allocate_dbcsr_matrix_set_5d(matrix_set, nmatrix, mmatrix, pmatrix, qmatrix, smatrix)
1383 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :, :), &
1384 POINTER :: matrix_set
1385 INTEGER, INTENT(IN) :: nmatrix, mmatrix, pmatrix, qmatrix, &
1386 smatrix
1387
1388 INTEGER :: hmatrix, imatrix, jmatrix, kmatrix, &
1389 lmatrix
1390
1391 IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1392 ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix, qmatrix, smatrix))
1393 DO hmatrix = 1, smatrix
1394 DO lmatrix = 1, qmatrix
1395 DO kmatrix = 1, pmatrix
1396 DO jmatrix = 1, mmatrix
1397 DO imatrix = 1, nmatrix
1398 NULLIFY (matrix_set(imatrix, jmatrix, kmatrix, lmatrix, hmatrix)%matrix)
1399 END DO
1400 END DO
1401 END DO
1402 END DO
1403 END DO
1404 END SUBROUTINE allocate_dbcsr_matrix_set_5d
1405
1406 ! **************************************************************************************************
1407!> \brief Deallocate a real matrix set and release all of the member matrices.
1408!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1409!> \par History
1410!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1411! **************************************************************************************************
1412 SUBROUTINE deallocate_dbcsr_matrix_set_1d(matrix_set)
1413
1414 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_set
1415
1416 INTEGER :: imatrix
1417
1418 IF (ASSOCIATED(matrix_set)) THEN
1419 DO imatrix = 1, SIZE(matrix_set)
1420 CALL dbcsr_deallocate_matrix(matrix_set(imatrix)%matrix)
1421 END DO
1422 DEALLOCATE (matrix_set)
1423 END IF
1424
1425 END SUBROUTINE deallocate_dbcsr_matrix_set_1d
1426
1427! **************************************************************************************************
1428!> \brief Deallocate a real matrix set and release all of the member matrices.
1429!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1430!> \par History
1431!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1432! **************************************************************************************************
1433 SUBROUTINE deallocate_dbcsr_matrix_set_2d(matrix_set)
1434
1435 TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_set
1436
1437 INTEGER :: imatrix, jmatrix
1438
1439 IF (ASSOCIATED(matrix_set)) THEN
1440 DO jmatrix = 1, SIZE(matrix_set, 2)
1441 DO imatrix = 1, SIZE(matrix_set, 1)
1442 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix)%matrix)
1443 END DO
1444 END DO
1445 DEALLOCATE (matrix_set)
1446 END IF
1447 END SUBROUTINE deallocate_dbcsr_matrix_set_2d
1448
1449! **************************************************************************************************
1450!> \brief Deallocate a real matrix set and release all of the member matrices.
1451!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1452!> \par History
1453!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1454! **************************************************************************************************
1455 SUBROUTINE deallocate_dbcsr_matrix_set_3d(matrix_set)
1456
1457 TYPE(dbcsr_p_type), DIMENSION(:, :, :), POINTER :: matrix_set
1458
1459 INTEGER :: imatrix, jmatrix, kmatrix
1460
1461 IF (ASSOCIATED(matrix_set)) THEN
1462 DO kmatrix = 1, SIZE(matrix_set, 3)
1463 DO jmatrix = 1, SIZE(matrix_set, 2)
1464 DO imatrix = 1, SIZE(matrix_set, 1)
1465 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix)%matrix)
1466 END DO
1467 END DO
1468 END DO
1469 DEALLOCATE (matrix_set)
1470 END IF
1471 END SUBROUTINE deallocate_dbcsr_matrix_set_3d
1472
1473! **************************************************************************************************
1474!> \brief Deallocate a real matrix set and release all of the member matrices.
1475!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1476!> \par History
1477!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1478! **************************************************************************************************
1479 SUBROUTINE deallocate_dbcsr_matrix_set_4d(matrix_set)
1480
1481 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :), POINTER :: matrix_set
1482
1483 INTEGER :: imatrix, jmatrix, kmatrix, lmatrix
1484
1485 IF (ASSOCIATED(matrix_set)) THEN
1486 DO lmatrix = 1, SIZE(matrix_set, 4)
1487 DO kmatrix = 1, SIZE(matrix_set, 3)
1488 DO jmatrix = 1, SIZE(matrix_set, 2)
1489 DO imatrix = 1, SIZE(matrix_set, 1)
1490 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix, lmatrix)%matrix)
1491 END DO
1492 END DO
1493 END DO
1494 END DO
1495 DEALLOCATE (matrix_set)
1496 END IF
1497 END SUBROUTINE deallocate_dbcsr_matrix_set_4d
1498
1499! **************************************************************************************************
1500!> \brief Deallocate a real matrix set and release all of the member matrices.
1501!> \param[in,out] matrix_set Set containing the DBCSR matrix pointer type
1502!> \par History
1503!> 2009-08-17 Adapted from sparse_matrix_type for DBCSR
1504! **************************************************************************************************
1505 SUBROUTINE deallocate_dbcsr_matrix_set_5d(matrix_set)
1506
1507 TYPE(dbcsr_p_type), DIMENSION(:, :, :, :, :), &
1508 POINTER :: matrix_set
1509
1510 INTEGER :: hmatrix, imatrix, jmatrix, kmatrix, &
1511 lmatrix
1512
1513 IF (ASSOCIATED(matrix_set)) THEN
1514 DO hmatrix = 1, SIZE(matrix_set, 5)
1515 DO lmatrix = 1, SIZE(matrix_set, 4)
1516 DO kmatrix = 1, SIZE(matrix_set, 3)
1517 DO jmatrix = 1, SIZE(matrix_set, 2)
1518 DO imatrix = 1, SIZE(matrix_set, 1)
1519 CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix, lmatrix, hmatrix)%matrix)
1520 END DO
1521 END DO
1522 END DO
1523 END DO
1524 END DO
1525 DEALLOCATE (matrix_set)
1526 END IF
1527 END SUBROUTINE deallocate_dbcsr_matrix_set_5d
1528
1529END 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:1287
cp_dbcsr_api::dbcsr_distribution_release
subroutine, public dbcsr_distribution_release(dist)
...
Definition cp_dbcsr_api.F:643
cp_dbcsr_api::dbcsr_scale
subroutine, public dbcsr_scale(matrix, alpha_scalar)
...
Definition cp_dbcsr_api.F:1188
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:616
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:861
cp_dbcsr_api::dbcsr_iterator_blocks_left
logical function, public dbcsr_iterator_blocks_left(iterator)
...
Definition cp_dbcsr_api.F:944
cp_dbcsr_api::dbcsr_iterator_stop
subroutine, public dbcsr_iterator_stop(iterator)
...
Definition cp_dbcsr_api.F:1050
cp_dbcsr_api::dbcsr_valid_index
logical function, public dbcsr_valid_index(matrix)
...
Definition cp_dbcsr_api.F:1270
cp_dbcsr_api::dbcsr_desymmetrize
subroutine, public dbcsr_desymmetrize(matrix_a, matrix_b)
...
Definition cp_dbcsr_api.F:525
cp_dbcsr_api::dbcsr_copy
subroutine, public dbcsr_copy(matrix_b, matrix_a, name, keep_sparsity, keep_imaginary)
...
Definition cp_dbcsr_api.F:371
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:1096
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:808
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:971
cp_dbcsr_api::dbcsr_iterator_start
subroutine, public dbcsr_iterator_start(iterator, matrix, shared, dynamic, dynamic_byrows)
...
Definition cp_dbcsr_api.F:1012
cp_dbcsr_api::dbcsr_release
subroutine, public dbcsr_release(matrix)
...
Definition cp_dbcsr_api.F:1142
cp_dbcsr_api::dbcsr_complete_redistribute
subroutine, public dbcsr_complete_redistribute(matrix, redist)
...
Definition cp_dbcsr_api.F:320
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:1033
cp_dbcsr_api::dbcsr_add
subroutine, public dbcsr_add(matrix_a, matrix_b, alpha_scalar, beta_scalar)
...
Definition cp_dbcsr_api.F:254
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:572
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:1084
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:858
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:935
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:693
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:892
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:475
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:355
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:1038
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:493
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:1324
mathlib::gcd
elemental integer function, public gcd(a, b)
computes the greatest common divisor of two number
Definition mathlib.F:1289
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:27
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:767