Line data Source code
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 : ! **************************************************************************************************
18 : MODULE 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 :
93 : CONTAINS
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 1457802 : 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 1457802 : CALL timeset(routineN, handle)
122 :
123 1457802 : my_keep_sparsity = .FALSE.
124 1457802 : IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity
125 :
126 1457802 : CALL copy_fm_to_dbcsr_bc(fm, bc_mat)
127 :
128 1457802 : IF (my_keep_sparsity) THEN
129 280208 : CALL dbcsr_create(redist_mat, template=matrix)
130 280208 : CALL dbcsr_complete_redistribute(bc_mat, redist_mat)
131 280208 : CALL dbcsr_copy(matrix, redist_mat, keep_sparsity=.TRUE.)
132 280208 : CALL dbcsr_release(redist_mat)
133 : ELSE
134 1177594 : CALL dbcsr_complete_redistribute(bc_mat, matrix)
135 : END IF
136 :
137 1457802 : CALL dbcsr_release(bc_mat)
138 :
139 1457802 : CALL timestop(handle)
140 1457802 : 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 1458190 : 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 1458190 : INTEGER, ALLOCATABLE, DIMENSION(:) :: first_col, first_row, last_col, last_row
157 1458190 : INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size
158 1458190 : INTEGER, DIMENSION(:, :), POINTER :: pgrid
159 1458190 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: dbcsr_block, fm_block
160 : TYPE(dbcsr_distribution_type) :: bc_dist
161 : TYPE(dbcsr_iterator_type) :: iter
162 :
163 1458190 : CALL timeset(routineN, handle)
164 :
165 : ! Create processor grid
166 1458190 : pgrid => fm%matrix_struct%context%blacs2mpi
167 :
168 : ! Create a block-cyclic distribution compatible with the FM matrix.
169 1458190 : nrow_block = fm%matrix_struct%nrow_block
170 1458190 : ncol_block = fm%matrix_struct%ncol_block
171 1458190 : nrow_global = fm%matrix_struct%nrow_global
172 1458190 : ncol_global = fm%matrix_struct%ncol_global
173 1458190 : 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 1458190 : 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 1458190 : dbcsr_type_no_symmetry, row_blk_size, col_blk_size, reuse_arrays=.TRUE.)
183 1458190 : CALL dbcsr_distribution_release(bc_dist)
184 :
185 : ! allocate all blocks
186 1458190 : CALL dbcsr_reserve_all_blocks(bc_mat)
187 :
188 1458190 : 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 1458190 : fm_block => fm%local_data
193 : !$OMP PARALLEL DEFAULT(NONE) PRIVATE(iter, row, col, dbcsr_block) &
194 1458190 : !$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 1458190 : CALL timestop(handle)
204 2916380 : 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 6326920 : 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 1581730 : INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size
222 1581730 : INTEGER, DIMENSION(:, :), POINTER :: pgrid
223 : TYPE(dbcsr_distribution_type) :: bc_dist, dist
224 : TYPE(dbcsr_type) :: bc_mat, matrix_nosym
225 :
226 1581730 : 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 1581730 : nfullcols_total=nfullcols_total)
234 :
235 1581730 : CPASSERT(fm%matrix_struct%nrow_global == nfullrows_total)
236 1581730 : CPASSERT(fm%matrix_struct%ncol_global == nfullcols_total)
237 :
238 : ! info about the full matrix
239 1581730 : nrow_block = fm%matrix_struct%nrow_block
240 1581730 : ncol_block = fm%matrix_struct%ncol_block
241 :
242 : ! Convert DBCSR to a block-cyclic
243 1581730 : NULLIFY (col_blk_size, row_blk_size)
244 1581730 : 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 1581730 : 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 1581730 : dbcsr_type_no_symmetry, row_blk_size, col_blk_size, reuse_arrays=.TRUE.)
253 1581730 : CALL dbcsr_distribution_release(bc_dist)
254 :
255 1581730 : CALL dbcsr_create(matrix_nosym, template=matrix, matrix_type="N")
256 1581730 : CALL dbcsr_desymmetrize(matrix, matrix_nosym)
257 1581730 : CALL dbcsr_complete_redistribute(matrix_nosym, bc_mat)
258 1581730 : CALL dbcsr_release(matrix_nosym)
259 :
260 1581730 : CALL copy_dbcsr_to_fm_bc(bc_mat, fm)
261 :
262 1581730 : CALL dbcsr_release(bc_mat)
263 :
264 1581730 : CALL timestop(handle)
265 1581730 : 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 1581730 : 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 1581730 : INTEGER, ALLOCATABLE, DIMENSION(:) :: first_col, first_row, last_col, last_row
280 1581730 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: dbcsr_block, fm_block
281 : TYPE(dbcsr_iterator_type) :: iter
282 :
283 1581730 : CALL timeset(routineN, handle)
284 :
285 1581730 : 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 1581730 : fm_block => fm%local_data
289 715254632 : fm_block = REAL(0.0, KIND=dp)
290 : !$OMP PARALLEL DEFAULT(NONE) PRIVATE(iter, row, col, dbcsr_block) &
291 1581730 : !$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 1581730 : CALL timestop(handle)
301 3163460 : 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 3039920 : 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 3039920 : INTEGER, DIMENSION(:), POINTER :: col_blk_size, local_cols, local_rows, &
320 3039920 : 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 3039920 : col_blk_size=col_blk_size)
331 :
332 : ! calculate first_row and last_row
333 9119208 : ALLOCATE (local_row_sizes(nblkrows_total))
334 3039920 : local_row_sizes(:) = 0
335 3039920 : IF (nblkrows_local >= 1) THEN
336 7582308 : DO row = 1, nblkrows_local
337 7582308 : local_row_sizes(local_rows(row)) = row_blk_size(local_rows(row))
338 : END DO
339 : END IF
340 9118656 : ALLOCATE (first_row(nblkrows_total), last_row(nblkrows_total))
341 3039920 : CALL dbcsr_convert_sizes_to_offsets(local_row_sizes, first_row, last_row)
342 3039920 : DEALLOCATE (local_row_sizes)
343 :
344 : ! calculate first_col and last_col
345 9117960 : ALLOCATE (local_col_sizes(nblkcols_total))
346 3039920 : local_col_sizes(:) = 0
347 3039920 : IF (nblkcols_local >= 1) THEN
348 9826794 : DO col = 1, nblkcols_local
349 9826794 : local_col_sizes(local_cols(col)) = col_blk_size(local_cols(col))
350 : END DO
351 : END IF
352 9116160 : ALLOCATE (first_col(nblkcols_total), last_col(nblkcols_total))
353 3039920 : CALL dbcsr_convert_sizes_to_offsets(local_col_sizes, first_col, last_col)
354 3039920 : DEALLOCATE (local_col_sizes)
355 :
356 3039920 : 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 9448 : 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 2362 : NULLIFY (fm_struct)
383 2362 : 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 2362 : ncol_global=nfullcols_total, para_env=para_env)
386 2362 : CALL cp_fm_create(fm_matrix_a, fm_struct, name="fm_matrix_a")
387 2362 : CALL cp_fm_struct_release(fm_struct)
388 :
389 2362 : 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 2362 : ncol_global=nfullcols_total, para_env=para_env)
392 2362 : CALL cp_fm_create(fm_matrix_b, fm_struct, name="fm_matrix_b")
393 2362 : CALL cp_fm_struct_release(fm_struct)
394 :
395 2362 : CALL copy_dbcsr_to_fm(matrix_a, fm_matrix_a)
396 2362 : CALL copy_dbcsr_to_fm(matrix_b, fm_matrix_b)
397 :
398 2362 : CALL cp_fm_to_fm(fm_matrix_a, fm_matrix_b, ncol, source_start, target_start)
399 :
400 2362 : CALL copy_fm_to_dbcsr(fm_matrix_b, matrix_b)
401 :
402 2362 : CALL cp_fm_release(fm_matrix_a)
403 2362 : CALL cp_fm_release(fm_matrix_b)
404 :
405 2362 : 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 11164 : 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 11164 : INTEGER, DIMENSION(:), POINTER :: col_dist, row_dist
419 11164 : 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 11164 : dist2d_p => dist2d
425 : CALL distribution_2d_get(dist2d_p, &
426 : row_distribution=row_dist_data, &
427 : col_distribution=col_dist_data, &
428 11164 : blacs_env=blacs_env)
429 11164 : CALL blacs_env%get(para_env=para_env, blacs2mpi=pgrid)
430 :
431 : ! map to 1D arrays
432 11164 : row_dist => row_dist_data(:, 1)
433 11164 : 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 11164 : col_dist=col_dist)
441 :
442 11164 : 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 0 : 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 0 : REAL(dp), DIMENSION(:, :), POINTER :: data_d
468 : TYPE(dbcsr_iterator_type) :: iter
469 :
470 0 : CALL timeset(routineN, timing_handle)
471 :
472 0 : my_alpha = 1.0_dp
473 0 : IF (PRESENT(alpha)) my_alpha = alpha
474 :
475 0 : my_ncol = SIZE(vec_b, 2)
476 0 : IF (PRESENT(ncol)) my_ncol = ncol
477 :
478 0 : my_alpha2 = 0.0_dp
479 0 : IF (dbcsr_get_matrix_type(matrix_a) == dbcsr_type_symmetric) my_alpha2 = my_alpha
480 0 : 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 0 : 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 0 : !$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 0 : IF (has_symm) THEN
509 0 : CALL dbcsr_iterator_readonly_start(iter, matrix_a)
510 0 : DO WHILE (dbcsr_iterator_blocks_left(iter))
511 0 : CALL dbcsr_iterator_next_block(iter, row, col, data_d, row_offset=rowoff, col_offset=coloff)
512 0 : IF (row /= col) THEN
513 0 : 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 0 : 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 0 : 1.0_dp, vec_c(coloff, 1), 1)
524 : END IF
525 : END IF
526 : END DO
527 0 : CALL dbcsr_iterator_stop(iter)
528 : END IF
529 :
530 0 : CALL timestop(timing_handle)
531 0 : 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 3098718 : 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 516453 : INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_blk_size_right_in, &
560 516453 : col_blk_size_right_out, col_dist, &
561 516453 : 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 516453 : CALL timeset(routineN, timing_handle)
567 :
568 516453 : my_alpha = 1.0_dp
569 516453 : my_beta = 0.0_dp
570 516453 : IF (PRESENT(alpha)) my_alpha = alpha
571 516453 : IF (PRESENT(beta)) my_beta = beta
572 :
573 : ! TODO
574 516453 : CALL cp_fm_get_info(fm_in, ncol_global=b_ncol, nrow_global=b_nrow)
575 516453 : CALL cp_fm_get_info(fm_out, ncol_global=c_ncol, nrow_global=c_nrow)
576 516453 : 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 516453 : CALL cp_fm_get_info(fm_out, ncol_global=k_out)
582 :
583 516453 : 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 516453 : IF (ncol > 0 .AND. k_out > 0 .AND. k_in > 0) THEN
591 515389 : CALL dbcsr_get_info(matrix, row_blk_size=row_blk_size, col_blk_size=col_blk_size, distribution=dist)
592 515389 : 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 515389 : col_blk_size, col_blk_size_right_in)
596 :
597 515389 : CALL dbcsr_distribution_get(dist, row_dist=row_dist)
598 515389 : CALL dbcsr_distribution_get(dist_right_in, col_dist=col_dist)
599 : CALL dbcsr_distribution_new(product_dist, template=dist, &
600 515389 : row_dist=row_dist, col_dist=col_dist)
601 1546167 : ALLOCATE (col_blk_size_right_out(SIZE(col_blk_size_right_in)))
602 2098288 : col_blk_size_right_out = col_blk_size_right_in
603 515389 : 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 515389 : row_blk_size, col_blk_size_right_out)
612 :
613 515389 : CALL copy_fm_to_dbcsr(fm_in, in)
614 515389 : IF (ncol /= k_out .OR. my_beta /= 0.0_dp) THEN
615 114386 : CALL copy_fm_to_dbcsr(fm_out, out)
616 : END IF
617 :
618 515389 : CALL timeset(routineN//'_core', timing_handle_mult)
619 : CALL dbcsr_multiply("N", "N", my_alpha, matrix, in, my_beta, out, &
620 515389 : last_column=ncol)
621 515389 : CALL timestop(timing_handle_mult)
622 :
623 515389 : CALL copy_dbcsr_to_fm(out, fm_out)
624 :
625 515389 : CALL dbcsr_release(in)
626 515389 : CALL dbcsr_release(out)
627 515389 : DEALLOCATE (col_blk_size_right_in, col_blk_size_right_out)
628 515389 : CALL dbcsr_distribution_release(dist_right_in)
629 2061556 : CALL dbcsr_distribution_release(product_dist)
630 :
631 : END IF
632 :
633 516453 : CALL timestop(timing_handle)
634 :
635 516453 : END SUBROUTINE cp_dbcsr_sm_fm_multiply
636 :
637 : ! **************************************************************************************************
638 : !> \brief ...
639 : !> \param sizes1 ...
640 : !> \param sizes2 ...
641 : !> \param full_num ...
642 : ! **************************************************************************************************
643 515389 : 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 515389 : n1 = SIZE(sizes1)
651 515389 : n2 = SIZE(sizes2)
652 515389 : IF (n1 /= n2) THEN
653 0 : CPABORT("distributions must be equal!")
654 : END IF
655 1049144 : sizes1(1:n1) = sizes2(1:n1)
656 1049144 : 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 515389 : IF (used < full_num) THEN
661 0 : sizes1(n1) = sizes1(n1) + full_num - used
662 : ELSE
663 515389 : left = used - full_num
664 515389 : p = n1
665 515389 : DO WHILE (left > 0 .AND. p > 0)
666 0 : rm = MIN(left, sizes1(p))
667 0 : sizes1(p) = sizes1(p) - rm
668 0 : left = left - rm
669 0 : p = p - 1
670 : END DO
671 : END IF
672 515389 : 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 249520 : 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 249520 : INTEGER, DIMENSION(:), POINTER :: col_blk_size_left, col_dist_left, &
706 249520 : 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 249520 : check_product = .FALSE.
716 :
717 249520 : CALL timeset(routineN, timing_handle)
718 :
719 249520 : my_keep_sparsity = .TRUE.
720 249520 : IF (PRESENT(keep_sparsity)) my_keep_sparsity = keep_sparsity
721 :
722 249520 : my_symmetry_mode = 0
723 249520 : IF (PRESENT(symmetry_mode)) my_symmetry_mode = symmetry_mode
724 :
725 249520 : NULLIFY (col_dist_left)
726 :
727 249520 : IF (ncol > 0) THEN
728 247948 : IF (.NOT. dbcsr_valid_index(sparse_matrix)) THEN
729 0 : CPABORT("sparse_matrix must pre-exist")
730 : END IF
731 : !
732 : ! Setup matrix_v
733 247948 : 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 247948 : CALL dbcsr_get_info(sparse_matrix, distribution=sparse_dist)
736 247948 : CALL dbcsr_distribution_get(sparse_dist, npcols=npcols, row_dist=row_dist)
737 247948 : CALL create_bl_distribution(col_dist_left, col_blk_size_left, k, npcols)
738 : CALL dbcsr_distribution_new(dist_left, template=sparse_dist, &
739 247948 : row_dist=row_dist, col_dist=col_dist_left)
740 247948 : DEALLOCATE (col_dist_left)
741 247948 : 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 247948 : row_blk_size, col_blk_size_left)
744 247948 : CALL copy_fm_to_dbcsr(matrix_v, mat_v)
745 247948 : CALL dbcsr_verify_matrix(mat_v)
746 : !
747 : ! Setup matrix_g
748 247948 : IF (PRESENT(matrix_g)) THEN
749 : CALL dbcsr_create(mat_g, "DBCSR matrix_g", dist_left, dbcsr_type_no_symmetry, &
750 120411 : row_blk_size, col_blk_size_left)
751 120411 : CALL copy_fm_to_dbcsr(matrix_g, mat_g)
752 : END IF
753 : !
754 247948 : DEALLOCATE (col_blk_size_left)
755 247948 : 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 247948 : my_alpha = 1.0_dp
769 247948 : IF (PRESENT(alpha)) my_alpha = alpha
770 247948 : IF (PRESENT(matrix_g)) THEN
771 120411 : 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 42274 : 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 42274 : last_k=ncol)
781 78137 : 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 2362 : 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 2362 : 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 75775 : 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 127537 : 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 247948 : CALL dbcsr_release(mat_v)
841 247948 : IF (PRESENT(matrix_g)) CALL dbcsr_release(mat_g)
842 : END IF
843 249520 : CALL timestop(timing_handle)
844 :
845 249520 : 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 15531 : 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 5177 : INTEGER, DIMENSION(:), POINTER :: col_blk_size_right_in, row_blk_size
864 : TYPE(dbcsr_distribution_type) :: dist_right_in, tmpl_dist
865 :
866 5177 : CALL cp_fm_get_info(fm_in, ncol_global=k_in)
867 :
868 5177 : CALL dbcsr_get_info(template, distribution=tmpl_dist)
869 5177 : CALL dbcsr_create_dist_r_unrot(dist_right_in, tmpl_dist, k_in, col_blk_size_right_in)
870 5177 : 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 5177 : row_blk_size, col_blk_size_right_in)
873 :
874 5177 : CALL copy_fm_to_dbcsr(fm_in, matrix)
875 5177 : DEALLOCATE (col_blk_size_right_in)
876 5177 : CALL dbcsr_distribution_release(dist_right_in)
877 :
878 5177 : 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 308656 : 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 154328 : INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_dist, row_blk_size, &
899 154328 : row_dist
900 : TYPE(dbcsr_distribution_type) :: dist_m_n, tmpl_dist
901 :
902 154328 : CALL dbcsr_get_info(template, matrix_type=mysym, distribution=tmpl_dist)
903 :
904 154328 : IF (PRESENT(sym)) mysym = sym
905 :
906 154328 : NULLIFY (row_dist, col_dist)
907 154328 : NULLIFY (row_blk_size, col_blk_size)
908 : !NULLIFY (row_cluster, col_cluster)
909 :
910 154328 : CALL dbcsr_distribution_get(tmpl_dist, nprows=nprows, npcols=npcols)
911 154328 : CALL create_bl_distribution(row_dist, row_blk_size, m, nprows)
912 154328 : 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 154328 : reuse_arrays=.TRUE.)
917 :
918 : CALL dbcsr_create(matrix, "m_n_template", dist_m_n, mysym, &
919 154328 : row_blk_size, col_blk_size, reuse_arrays=.TRUE.)
920 154328 : CALL dbcsr_distribution_release(dist_m_n)
921 :
922 154328 : 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 569472 : 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 142368 : INTEGER, DIMENSION(:), POINTER :: col_blk_size, col_dist, row_blk_size, &
942 142368 : row_dist
943 : TYPE(dbcsr_distribution_type) :: dist_m_n, tmpl_dist
944 :
945 284736 : mysym = dbcsr_get_matrix_type(template)
946 142368 : IF (PRESENT(sym)) mysym = sym
947 :
948 142368 : CALL dbcsr_get_info(template, distribution=tmpl_dist)
949 : CALL dbcsr_distribution_get(tmpl_dist, &
950 : npcols=npcols, &
951 142368 : row_dist=row_dist)
952 :
953 142368 : NULLIFY (col_dist, col_blk_size)
954 142368 : CALL create_bl_distribution(col_dist, col_blk_size, n, npcols)
955 : CALL dbcsr_distribution_new(dist_m_n, template=tmpl_dist, &
956 142368 : row_dist=row_dist, col_dist=col_dist)
957 :
958 142368 : CALL dbcsr_get_info(template, row_blk_size=row_blk_size)
959 142368 : CALL dbcsr_create(matrix, "m_n_template", dist_m_n, mysym, row_blk_size, col_blk_size)
960 :
961 142368 : DEALLOCATE (col_dist, col_blk_size)
962 142368 : CALL dbcsr_distribution_release(dist_m_n)
963 :
964 142368 : 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 1219538 : 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 1219538 : INTEGER, DIMENSION(:), POINTER :: blk_dist, blk_sizes
988 :
989 : ! ---------------------------------------------------------------------------
990 :
991 1219538 : NULLIFY (block_distribution)
992 1219538 : NULLIFY (block_size)
993 : ! Define the sizes on which we build the distribution.
994 1219538 : IF (nelements > 0) THEN
995 :
996 1211446 : nblocks = CEILING(REAL(nelements, KIND=dp)/REAL(max_elements_per_block, KIND=dp))
997 1211446 : 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 1211446 : estimated_blocks = max_blocks_per_bin*nbins
1011 3634338 : ALLOCATE (blk_dist(estimated_blocks), stat=stat)
1012 1211446 : IF (stat /= 0) THEN
1013 0 : CPABORT("blk_dist")
1014 : END IF
1015 2422892 : ALLOCATE (blk_sizes(estimated_blocks), stat=stat)
1016 : IF (stat /= 0) THEN
1017 0 : CPABORT("blk_sizes")
1018 : END IF
1019 1211446 : element_stack = 0
1020 1211446 : nblks = 0
1021 2504606 : DO blk_layer = 1, max_blocks_per_bin
1022 3932688 : DO bin = 0, nbins - 1
1023 1428082 : els = MIN(max_elements_per_block, nelements - element_stack)
1024 2721242 : IF (els > 0) THEN
1025 1304016 : element_stack = element_stack + els
1026 1304016 : nblks = nblks + 1
1027 1304016 : blk_dist(nblks) = bin
1028 1304016 : 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 1211446 : IF (nblks == estimated_blocks) THEN
1036 1087380 : block_distribution => blk_dist
1037 1087380 : block_size => blk_sizes
1038 : ELSE
1039 372198 : ALLOCATE (block_distribution(nblks), stat=stat)
1040 : IF (stat /= 0) THEN
1041 0 : CPABORT("blk_dist")
1042 : END IF
1043 499544 : block_distribution(:) = blk_dist(1:nblks)
1044 124066 : DEALLOCATE (blk_dist)
1045 248132 : ALLOCATE (block_size(nblks), stat=stat)
1046 : IF (stat /= 0) THEN
1047 0 : CPABORT("blk_sizes")
1048 : END IF
1049 499544 : block_size(:) = blk_sizes(1:nblks)
1050 124066 : DEALLOCATE (blk_sizes)
1051 : END IF
1052 : ELSE
1053 8092 : ALLOCATE (block_distribution(0), stat=stat)
1054 : IF (stat /= 0) THEN
1055 0 : CPABORT("blk_dist")
1056 : END IF
1057 8092 : ALLOCATE (block_size(0), stat=stat)
1058 : IF (stat /= 0) THEN
1059 0 : CPABORT("blk_sizes")
1060 : END IF
1061 : END IF
1062 : 1579 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 1219538 : 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 520566 : 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 520566 : INTEGER, DIMENSION(:), POINTER :: old_col_dist, right_col_dist, &
1093 520566 : right_row_dist
1094 :
1095 : CALL dbcsr_distribution_get(dist_left, &
1096 : ncols=ncols, &
1097 : col_dist=old_col_dist, &
1098 : nprows=nprows, &
1099 520566 : npcols=npcols)
1100 :
1101 : ! Create the column distribution
1102 520566 : CALL create_bl_distribution(right_col_dist, right_col_blk_sizes, ncolumns, npcols)
1103 : ! Create an even row distribution.
1104 2082264 : ALLOCATE (right_row_dist(ncols), tmp_images(ncols))
1105 520566 : nimages = lcm(nprows, npcols)/nprows
1106 520566 : multiplicity = nprows/gcd(nprows, npcols)
1107 520566 : 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 520566 : reuse_arrays=.TRUE.)
1116 520566 : DEALLOCATE (tmp_images)
1117 520566 : 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 520566 : 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 520566 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bin_multiplier
1160 :
1161 : ! ---------------------------------------------------------------------------
1162 :
1163 520566 : IF (MOD(nbins*nimages, multiplicity) /= 0) THEN
1164 0 : CPWARN("mulitplicity is not divisor of new process grid coordinate")
1165 : END IF
1166 520566 : old_nbins = (nbins*nimages)/multiplicity
1167 1561698 : ALLOCATE (bin_multiplier(0:old_nbins - 1))
1168 520566 : bin_multiplier(:) = 0
1169 2472379 : DO i = 1, SIZE(new_bins)
1170 1951813 : IF (i <= SIZE(source_bins)) THEN
1171 1951813 : bin = source_bins(i)
1172 : ELSE
1173 : ! Fill remainder with a cyclic distribution
1174 0 : bin = MOD(i, old_nbins)
1175 : END IF
1176 1951813 : virtual_bin = bin*multiplicity + bin_multiplier(bin)
1177 1951813 : new_bins(i) = virtual_bin/nimages
1178 1951813 : images(i) = 1 + MOD(virtual_bin, nimages)
1179 1951813 : bin_multiplier(bin) = bin_multiplier(bin) + 1
1180 2472379 : IF (bin_multiplier(bin) >= multiplicity) THEN
1181 832841 : bin_multiplier(bin) = 0
1182 : END IF
1183 : END DO
1184 520566 : 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 3039920 : 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 3039920 : INTEGER, DIMENSION(:), POINTER :: cd_data, rd_data
1214 :
1215 : ! Row sizes
1216 3039920 : IF (nrow_block == 0) THEN
1217 : nblkrows = 0
1218 : sz = 0
1219 : ELSE
1220 3039920 : nblkrows = nrows/nrow_block
1221 3039920 : sz = MOD(nrows, nrow_block)
1222 : END IF
1223 3039920 : IF (sz > 0) nblkrows = nblkrows + 1
1224 12158576 : ALLOCATE (row_blk_sizes(nblkrows), rd_data(nblkrows))
1225 12051622 : row_blk_sizes = nrow_block
1226 3039920 : IF (sz /= 0) row_blk_sizes(nblkrows) = sz
1227 :
1228 : ! Column sizes
1229 3039920 : IF (ncol_block == 0) THEN
1230 : nblkcols = 0
1231 : sz = 0
1232 : ELSE
1233 3039920 : nblkcols = ncolumns/ncol_block
1234 3039920 : sz = MOD(ncolumns, ncol_block)
1235 : END IF
1236 3039920 : IF (sz > 0) nblkcols = nblkcols + 1
1237 12156080 : ALLOCATE (col_blk_sizes(nblkcols), cd_data(nblkcols))
1238 9828594 : col_blk_sizes = ncol_block
1239 3039920 : 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 3039920 : nprows = SIZE(pgrid, 1)
1249 9045148 : DO pdim = 0, MIN(nprows - 1, nblkrows - 1)
1250 18056850 : rd_data(1 + pdim:nblkrows:nprows) = pdim
1251 : END DO
1252 : ! Calculate process column distribution
1253 3039920 : npcols = SIZE(pgrid, 2)
1254 6078040 : DO pdim = 0, MIN(npcols - 1, nblkcols - 1)
1255 12866714 : 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 3039920 : reuse_arrays=.TRUE.)
1270 :
1271 3039920 : 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 196801 : 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 196801 : IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1287 1365066 : ALLOCATE (matrix_set(nmatrix))
1288 971464 : DO imatrix = 1, nmatrix
1289 971464 : NULLIFY (matrix_set(imatrix)%matrix)
1290 : END DO
1291 196801 : 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 189726 : 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 189726 : IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1308 4292928 : ALLOCATE (matrix_set(nmatrix, mmatrix))
1309 1838816 : DO jmatrix = 1, mmatrix
1310 3723750 : DO imatrix = 1, nmatrix
1311 3534024 : NULLIFY (matrix_set(imatrix, jmatrix)%matrix)
1312 : END DO
1313 : END DO
1314 189726 : 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 0 : 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 0 : IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1332 0 : ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix))
1333 0 : DO kmatrix = 1, pmatrix
1334 0 : DO jmatrix = 1, mmatrix
1335 0 : DO imatrix = 1, nmatrix
1336 0 : NULLIFY (matrix_set(imatrix, jmatrix, kmatrix)%matrix)
1337 : END DO
1338 : END DO
1339 : END DO
1340 0 : 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 0 : 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 0 : IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1359 0 : ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix, qmatrix))
1360 0 : DO lmatrix = 1, qmatrix
1361 0 : DO kmatrix = 1, pmatrix
1362 0 : DO jmatrix = 1, mmatrix
1363 0 : DO imatrix = 1, nmatrix
1364 0 : NULLIFY (matrix_set(imatrix, jmatrix, kmatrix, lmatrix)%matrix)
1365 : END DO
1366 : END DO
1367 : END DO
1368 : END DO
1369 0 : 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 0 : 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 0 : IF (ASSOCIATED(matrix_set)) CALL dbcsr_deallocate_matrix_set(matrix_set)
1392 0 : ALLOCATE (matrix_set(nmatrix, mmatrix, pmatrix, qmatrix, smatrix))
1393 0 : DO hmatrix = 1, smatrix
1394 0 : DO lmatrix = 1, qmatrix
1395 0 : DO kmatrix = 1, pmatrix
1396 0 : DO jmatrix = 1, mmatrix
1397 0 : DO imatrix = 1, nmatrix
1398 0 : 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 0 : 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 195552 : SUBROUTINE deallocate_dbcsr_matrix_set_1d(matrix_set)
1413 :
1414 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_set
1415 :
1416 : INTEGER :: imatrix
1417 :
1418 195552 : IF (ASSOCIATED(matrix_set)) THEN
1419 969392 : DO imatrix = 1, SIZE(matrix_set)
1420 969392 : CALL dbcsr_deallocate_matrix(matrix_set(imatrix)%matrix)
1421 : END DO
1422 193894 : DEALLOCATE (matrix_set)
1423 : END IF
1424 :
1425 195552 : 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 194183 : 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 194183 : IF (ASSOCIATED(matrix_set)) THEN
1440 1849036 : DO jmatrix = 1, SIZE(matrix_set, 2)
1441 3744311 : DO imatrix = 1, SIZE(matrix_set, 1)
1442 3553152 : CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix)%matrix)
1443 : END DO
1444 : END DO
1445 191159 : DEALLOCATE (matrix_set)
1446 : END IF
1447 194183 : 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 0 : 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 0 : IF (ASSOCIATED(matrix_set)) THEN
1462 0 : DO kmatrix = 1, SIZE(matrix_set, 3)
1463 0 : DO jmatrix = 1, SIZE(matrix_set, 2)
1464 0 : DO imatrix = 1, SIZE(matrix_set, 1)
1465 0 : CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix)%matrix)
1466 : END DO
1467 : END DO
1468 : END DO
1469 0 : DEALLOCATE (matrix_set)
1470 : END IF
1471 0 : 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 0 : 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 0 : IF (ASSOCIATED(matrix_set)) THEN
1486 0 : DO lmatrix = 1, SIZE(matrix_set, 4)
1487 0 : DO kmatrix = 1, SIZE(matrix_set, 3)
1488 0 : DO jmatrix = 1, SIZE(matrix_set, 2)
1489 0 : DO imatrix = 1, SIZE(matrix_set, 1)
1490 0 : CALL dbcsr_deallocate_matrix(matrix_set(imatrix, jmatrix, kmatrix, lmatrix)%matrix)
1491 : END DO
1492 : END DO
1493 : END DO
1494 : END DO
1495 0 : DEALLOCATE (matrix_set)
1496 : END IF
1497 0 : 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 0 : 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 0 : IF (ASSOCIATED(matrix_set)) THEN
1514 0 : DO hmatrix = 1, SIZE(matrix_set, 5)
1515 0 : DO lmatrix = 1, SIZE(matrix_set, 4)
1516 0 : DO kmatrix = 1, SIZE(matrix_set, 3)
1517 0 : DO jmatrix = 1, SIZE(matrix_set, 2)
1518 0 : DO imatrix = 1, SIZE(matrix_set, 1)
1519 0 : 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 0 : DEALLOCATE (matrix_set)
1526 : END IF
1527 0 : END SUBROUTINE deallocate_dbcsr_matrix_set_5d
1528 :
1529 : END MODULE cp_dbcsr_operations
|
