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 output in CP2K
10 : !> \author VW
11 : !> \date 2009-09-09
12 : !> \version 0.1
13 : !>
14 : !> <b>Modification history:</b>
15 : !> - Created 2009-09-09
16 : ! **************************************************************************************************
17 : MODULE cp_dbcsr_output
18 : USE atomic_kind_types, ONLY: atomic_kind_type,&
19 : get_atomic_kind
20 : USE basis_set_types, ONLY: get_gto_basis_set,&
21 : gto_basis_set_type
22 : USE cp_dbcsr_api, ONLY: &
23 : dbcsr_get_data_size, dbcsr_get_info, dbcsr_get_matrix_type, dbcsr_get_num_blocks, &
24 : dbcsr_iterator_blocks_left, dbcsr_iterator_next_block, dbcsr_iterator_start, &
25 : dbcsr_iterator_stop, dbcsr_iterator_type, dbcsr_type, dbcsr_type_antisymmetric, &
26 : dbcsr_type_no_symmetry, dbcsr_type_symmetric
27 : USE cp_fm_types, ONLY: cp_fm_get_info,&
28 : cp_fm_get_submatrix,&
29 : cp_fm_type
30 : USE cp_log_handling, ONLY: cp_get_default_logger,&
31 : cp_logger_type
32 : USE kinds, ONLY: default_string_length,&
33 : dp,&
34 : int_8
35 : USE machine, ONLY: m_flush
36 : USE mathlib, ONLY: symmetrize_matrix
37 : USE message_passing, ONLY: mp_para_env_type
38 : USE orbital_pointers, ONLY: nco,&
39 : nso
40 : USE particle_methods, ONLY: get_particle_set
41 : USE particle_types, ONLY: particle_type
42 : USE qs_environment_types, ONLY: get_qs_env,&
43 : qs_environment_type
44 : USE qs_kind_types, ONLY: get_qs_kind,&
45 : get_qs_kind_set,&
46 : qs_kind_type
47 : #include "./base/base_uses.f90"
48 :
49 : IMPLICIT NONE
50 :
51 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_dbcsr_output'
52 :
53 : PUBLIC :: cp_dbcsr_write_sparse_matrix
54 : PUBLIC :: cp_dbcsr_write_matrix_dist
55 : PUBLIC :: write_fm_with_basis_info
56 :
57 : PRIVATE
58 :
59 : CONTAINS
60 :
61 : ! **************************************************************************************************
62 : !> \brief Print a spherical matrix of blacs type.
63 : !> \param blacs_matrix ...
64 : !> \param before ...
65 : !> \param after ...
66 : !> \param qs_env ...
67 : !> \param para_env ...
68 : !> \param first_row ...
69 : !> \param last_row ...
70 : !> \param first_col ...
71 : !> \param last_col ...
72 : !> \param output_unit ...
73 : !> \param omit_headers Write only the matrix data, not the row/column headers
74 : !> \author Creation (12.06.2001,MK)
75 : !> Allow for printing of a sub-matrix (01.07.2003,MK)
76 : ! **************************************************************************************************
77 8 : SUBROUTINE write_fm_with_basis_info(blacs_matrix, before, after, qs_env, para_env, &
78 : first_row, last_row, first_col, last_col, output_unit, omit_headers)
79 :
80 : TYPE(cp_fm_type), INTENT(IN) :: blacs_matrix
81 : INTEGER, INTENT(IN) :: before, after
82 : TYPE(qs_environment_type), POINTER :: qs_env
83 : TYPE(mp_para_env_type), POINTER :: para_env
84 : INTEGER, INTENT(IN), OPTIONAL :: first_row, last_row, first_col, last_col
85 : INTEGER, INTENT(IN) :: output_unit
86 : LOGICAL, INTENT(IN), OPTIONAL :: omit_headers
87 :
88 : CHARACTER(LEN=60) :: matrix_name
89 : INTEGER :: col1, col2, ncol_global, nrow_global, &
90 : nsgf, row1, row2
91 : LOGICAL :: my_omit_headers
92 8 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: matrix
93 8 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
94 :
95 0 : IF (.NOT. ASSOCIATED(blacs_matrix%matrix_struct)) RETURN
96 : CALL cp_fm_get_info(blacs_matrix, name=matrix_name, nrow_global=nrow_global, &
97 8 : ncol_global=ncol_global)
98 :
99 32 : ALLOCATE (matrix(nrow_global, ncol_global))
100 8 : CALL cp_fm_get_submatrix(blacs_matrix, matrix)
101 :
102 : ! *** Get the matrix dimension and check the optional arguments ***
103 8 : CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set)
104 8 : CALL get_qs_kind_set(qs_kind_set=qs_kind_set, nsgf=nsgf)
105 :
106 8 : IF (PRESENT(first_row)) THEN
107 0 : row1 = MAX(1, first_row)
108 : ELSE
109 8 : row1 = 1
110 : END IF
111 :
112 8 : IF (PRESENT(last_row)) THEN
113 0 : row2 = MIN(nsgf, last_row)
114 : ELSE
115 8 : row2 = nsgf
116 : END IF
117 :
118 8 : IF (PRESENT(first_col)) THEN
119 0 : col1 = MAX(1, first_col)
120 : ELSE
121 8 : col1 = 1
122 : END IF
123 :
124 8 : IF (PRESENT(last_col)) THEN
125 0 : col2 = MIN(nsgf, last_col)
126 : ELSE
127 8 : col2 = nsgf
128 : END IF
129 :
130 8 : IF (PRESENT(omit_headers)) THEN
131 4 : my_omit_headers = omit_headers
132 : ELSE
133 4 : my_omit_headers = .FALSE.
134 : END IF
135 :
136 : CALL write_matrix_sym(matrix, matrix_name, before, after, qs_env, para_env, &
137 8 : row1, row2, col1, col2, output_unit, omit_headers=my_omit_headers)
138 :
139 : ! *** Release work storage ***
140 8 : IF (ASSOCIATED(matrix)) THEN
141 8 : DEALLOCATE (matrix)
142 : END IF
143 :
144 16 : END SUBROUTINE write_fm_with_basis_info
145 :
146 : ! **************************************************************************************************
147 : !> \brief ...
148 : !> \param sparse_matrix ...
149 : !> \param before ...
150 : !> \param after ...
151 : !> \param qs_env ...
152 : !> \param para_env ...
153 : !> \param first_row ...
154 : !> \param last_row ...
155 : !> \param first_col ...
156 : !> \param last_col ...
157 : !> \param scale ...
158 : !> \param output_unit ...
159 : !> \param omit_headers Write only the matrix data, not the row/column headers
160 : !> \param cartesian_basis Use Cartesian instead of spherical basis labels
161 : ! **************************************************************************************************
162 15898 : SUBROUTINE cp_dbcsr_write_sparse_matrix(sparse_matrix, before, after, qs_env, para_env, &
163 : first_row, last_row, first_col, last_col, scale, &
164 : output_unit, omit_headers, cartesian_basis)
165 :
166 : TYPE(dbcsr_type) :: sparse_matrix
167 : INTEGER, INTENT(IN) :: before, after
168 : TYPE(qs_environment_type), POINTER :: qs_env
169 : TYPE(mp_para_env_type), POINTER :: para_env
170 : INTEGER, INTENT(IN), OPTIONAL :: first_row, last_row, first_col, last_col
171 : REAL(dp), INTENT(IN), OPTIONAL :: scale
172 : INTEGER, INTENT(IN) :: output_unit
173 : LOGICAL, INTENT(IN), OPTIONAL :: omit_headers, cartesian_basis
174 :
175 : CHARACTER(LEN=default_string_length) :: matrix_name
176 : INTEGER :: col1, col2, dim_col, dim_row, row1, row2
177 : LOGICAL :: my_cartesian_basis, my_omit_headers, &
178 : print_sym
179 15898 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: matrix
180 15898 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
181 :
182 15898 : NULLIFY (matrix)
183 :
184 15898 : CALL copy_repl_dbcsr_to_repl_fm(sparse_matrix, matrix)
185 :
186 3458410 : CALL para_env%sum(matrix)
187 :
188 15862 : SELECT CASE (dbcsr_get_matrix_type(sparse_matrix))
189 : CASE (dbcsr_type_symmetric)
190 15862 : CALL symmetrize_matrix(matrix, "upper_to_lower")
191 15862 : print_sym = .TRUE.
192 : CASE (dbcsr_type_antisymmetric)
193 36 : CALL symmetrize_matrix(matrix, "anti_upper_to_lower")
194 36 : print_sym = .TRUE.
195 : CASE (dbcsr_type_no_symmetry)
196 0 : print_sym = .FALSE.
197 : CASE DEFAULT
198 15898 : CPABORT("WRONG")
199 : END SELECT
200 :
201 : ! *** Get the matrix dimension and check the optional arguments ***
202 15898 : CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set)
203 15898 : dim_row = SIZE(matrix, 1)
204 15898 : dim_col = SIZE(matrix, 2)
205 :
206 15898 : IF (PRESENT(first_row)) THEN
207 0 : row1 = MAX(1, first_row)
208 : ELSE
209 15898 : row1 = 1
210 : END IF
211 :
212 15898 : IF (PRESENT(last_row)) THEN
213 0 : row2 = MIN(dim_row, last_row)
214 : ELSE
215 15898 : row2 = dim_row
216 : END IF
217 :
218 15898 : IF (PRESENT(first_col)) THEN
219 0 : col1 = MAX(1, first_col)
220 : ELSE
221 15898 : col1 = 1
222 : END IF
223 :
224 15898 : IF (PRESENT(last_col)) THEN
225 0 : col2 = MIN(dim_col, last_col)
226 : ELSE
227 15898 : col2 = dim_col
228 : END IF
229 :
230 15898 : IF (PRESENT(scale)) THEN
231 810266 : matrix = matrix*scale
232 : END IF
233 :
234 15898 : IF (PRESENT(omit_headers)) THEN
235 15698 : my_omit_headers = omit_headers
236 : ELSE
237 200 : my_omit_headers = .FALSE.
238 : END IF
239 15898 : my_cartesian_basis = .FALSE.
240 15898 : IF (PRESENT(cartesian_basis)) my_cartesian_basis = cartesian_basis
241 :
242 15898 : CALL dbcsr_get_info(sparse_matrix, name=matrix_name)
243 15898 : IF (print_sym) THEN
244 : CALL write_matrix_sym(matrix, matrix_name, before, after, qs_env, para_env, &
245 : row1, row2, col1, col2, output_unit, my_omit_headers, &
246 15898 : cartesian_basis=my_cartesian_basis)
247 : ELSE
248 : CALL write_matrix_gen(matrix, matrix_name, before, after, para_env, &
249 0 : row1, row2, col1, col2, output_unit, my_omit_headers)
250 : END IF
251 :
252 15898 : IF (ASSOCIATED(matrix)) THEN
253 15898 : DEALLOCATE (matrix)
254 : END IF
255 :
256 15898 : END SUBROUTINE cp_dbcsr_write_sparse_matrix
257 :
258 : ! **************************************************************************************************
259 : !> \brief ...
260 : !> \param sparse_matrix ...
261 : !> \param fm ...
262 : ! **************************************************************************************************
263 15898 : SUBROUTINE copy_repl_dbcsr_to_repl_fm(sparse_matrix, fm)
264 :
265 : TYPE(dbcsr_type) :: sparse_matrix
266 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: fm
267 :
268 : CHARACTER(len=*), PARAMETER :: routineN = 'copy_repl_dbcsr_to_repl_fm'
269 :
270 : INTEGER :: col, handle, i, j, nblkcols_total, &
271 : nblkrows_total, nc, nr, row
272 15898 : INTEGER, ALLOCATABLE, DIMENSION(:) :: c_offset, r_offset
273 15898 : INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size
274 15898 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: block
275 : TYPE(dbcsr_iterator_type) :: iter
276 :
277 15898 : CALL timeset(routineN, handle)
278 :
279 15898 : IF (ASSOCIATED(fm)) DEALLOCATE (fm)
280 :
281 : CALL dbcsr_get_info(matrix=sparse_matrix, &
282 : col_blk_size=col_blk_size, &
283 : row_blk_size=row_blk_size, &
284 : nblkrows_total=nblkrows_total, &
285 15898 : nblkcols_total=nblkcols_total)
286 :
287 : !> this should be precomputed somewhere else
288 79490 : ALLOCATE (r_offset(nblkrows_total), c_offset(nblkcols_total))
289 :
290 15898 : r_offset(1) = 1
291 33496 : DO row = 2, nblkrows_total
292 33496 : r_offset(row) = r_offset(row - 1) + row_blk_size(row - 1)
293 : END DO
294 49394 : nr = SUM(row_blk_size)
295 15898 : c_offset(1) = 1
296 33496 : DO col = 2, nblkcols_total
297 33496 : c_offset(col) = c_offset(col - 1) + col_blk_size(col - 1)
298 : END DO
299 49394 : nc = SUM(col_blk_size)
300 : !<
301 :
302 63592 : ALLOCATE (fm(nr, nc))
303 :
304 1737154 : fm(:, :) = 0.0_dp
305 :
306 15898 : CALL dbcsr_iterator_start(iter, sparse_matrix)
307 42510 : DO WHILE (dbcsr_iterator_blocks_left(iter))
308 26612 : CALL dbcsr_iterator_next_block(iter, row, col, block)
309 187326 : DO j = 1, SIZE(block, 2)
310 866366 : DO i = 1, SIZE(block, 1)
311 839754 : fm(r_offset(row) + i - 1, c_offset(col) + j - 1) = block(i, j)
312 : END DO
313 : END DO
314 : END DO
315 15898 : CALL dbcsr_iterator_stop(iter)
316 :
317 15898 : DEALLOCATE (r_offset, c_offset)
318 :
319 15898 : CALL timestop(handle)
320 :
321 47694 : END SUBROUTINE copy_repl_dbcsr_to_repl_fm
322 :
323 : ! **************************************************************************************************
324 : !> \brief Write a matrix or a sub-matrix to the output unit (symmetric)
325 : !> \param matrix ...
326 : !> \param matrix_name ...
327 : !> \param before ...
328 : !> \param after ...
329 : !> \param qs_env ...
330 : !> \param para_env ...
331 : !> \param first_row ...
332 : !> \param last_row ...
333 : !> \param first_col ...
334 : !> \param last_col ...
335 : !> \param output_unit ...
336 : !> \param omit_headers Write only the matrix data, not the row/column headers
337 : !> \param cartesian_basis Use Cartesian instead of spherical basis labels
338 : !> \author Creation (01.07.2003,MK)
339 : ! **************************************************************************************************
340 15906 : SUBROUTINE write_matrix_sym(matrix, matrix_name, before, after, qs_env, para_env, &
341 : first_row, last_row, first_col, last_col, output_unit, omit_headers, cartesian_basis)
342 :
343 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: matrix
344 : CHARACTER(LEN=*), INTENT(IN) :: matrix_name
345 : INTEGER, INTENT(IN) :: before, after
346 : TYPE(qs_environment_type), POINTER :: qs_env
347 : TYPE(mp_para_env_type), POINTER :: para_env
348 : INTEGER, INTENT(IN) :: first_row, last_row, first_col, &
349 : last_col, output_unit
350 : LOGICAL, INTENT(IN) :: omit_headers
351 : LOGICAL, INTENT(IN), OPTIONAL :: cartesian_basis
352 :
353 15906 : CHARACTER(LEN=12), DIMENSION(:), POINTER :: cgf_symbol
354 : CHARACTER(LEN=2) :: element_symbol
355 : CHARACTER(LEN=25) :: fmtstr1
356 : CHARACTER(LEN=35) :: fmtstr2
357 15906 : CHARACTER(LEN=6), DIMENSION(:), POINTER :: sgf_symbol
358 : INTEGER :: from, iatom, icol, ikind, irow, iset, &
359 : isgf, ishell, iso, jcol, l, left, &
360 : natom, ncol, ndigits, nset, nsgf, &
361 : right, to, width
362 15906 : INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf, last_sgf
363 15906 : INTEGER, DIMENSION(:), POINTER :: nshell
364 15906 : INTEGER, DIMENSION(:, :), POINTER :: lshell
365 : LOGICAL :: my_cartesian_basis
366 15906 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
367 : TYPE(gto_basis_set_type), POINTER :: orb_basis_set
368 15906 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
369 15906 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
370 :
371 15906 : IF (output_unit > 0) THEN
372 7953 : CALL m_flush(output_unit)
373 :
374 : CALL get_qs_env(qs_env=qs_env, &
375 : qs_kind_set=qs_kind_set, &
376 : atomic_kind_set=atomic_kind_set, &
377 7953 : particle_set=particle_set)
378 :
379 7953 : natom = SIZE(particle_set)
380 :
381 7953 : my_cartesian_basis = .FALSE.
382 7953 : IF (PRESENT(cartesian_basis)) my_cartesian_basis = cartesian_basis
383 :
384 7953 : CALL get_qs_kind_set(qs_kind_set=qs_kind_set, nsgf=nsgf)
385 :
386 23859 : ALLOCATE (first_sgf(natom))
387 15906 : ALLOCATE (last_sgf(natom))
388 : CALL get_particle_set(particle_set, qs_kind_set, &
389 : first_sgf=first_sgf, &
390 7953 : last_sgf=last_sgf)
391 :
392 : ! *** Definition of the variable formats ***
393 7953 : fmtstr1 = "(/,T2,23X, ( X,I5, X))"
394 7953 : IF (omit_headers) THEN
395 46 : fmtstr2 = "(T2, (1X,F . ))"
396 : ELSE
397 7907 : fmtstr2 = "(T2,2I5,2X,A2,1X,A8, (1X,F . ))"
398 : END IF
399 :
400 : ! *** Write headline ***
401 7953 : WRITE (UNIT=output_unit, FMT="(/,/,T2,A)") TRIM(matrix_name)
402 :
403 : ! *** Write the variable format strings ***
404 7953 : ndigits = after
405 :
406 7953 : width = before + ndigits + 3
407 7953 : ncol = INT(56/width)
408 :
409 7953 : right = MAX((ndigits - 2), 1)
410 7953 : left = width - right - 5
411 :
412 7953 : WRITE (UNIT=fmtstr1(11:12), FMT="(I2)") ncol
413 7953 : WRITE (UNIT=fmtstr1(14:15), FMT="(I2)") left
414 7953 : WRITE (UNIT=fmtstr1(21:22), FMT="(I2)") right
415 :
416 7953 : IF (omit_headers) THEN
417 46 : WRITE (UNIT=fmtstr2(6:7), FMT="(I2)") ncol
418 46 : WRITE (UNIT=fmtstr2(13:14), FMT="(I2)") width - 1
419 46 : WRITE (UNIT=fmtstr2(16:17), FMT="(I2)") ndigits
420 : ELSE
421 7907 : WRITE (UNIT=fmtstr2(22:23), FMT="(I2)") ncol
422 7907 : WRITE (UNIT=fmtstr2(29:30), FMT="(I2)") width - 1
423 7907 : WRITE (UNIT=fmtstr2(32:33), FMT="(I2)") ndigits
424 : END IF
425 :
426 : ! *** Write the matrix in the selected format ***
427 31333 : DO icol = first_col, last_col, ncol
428 23380 : from = icol
429 23380 : to = MIN((from + ncol - 1), last_col)
430 23380 : IF (.NOT. omit_headers) THEN
431 99931 : WRITE (UNIT=output_unit, FMT=fmtstr1) (jcol, jcol=from, to)
432 : END IF
433 23380 : irow = 1
434 80794 : DO iatom = 1, natom
435 49461 : NULLIFY (orb_basis_set)
436 : CALL get_atomic_kind(particle_set(iatom)%atomic_kind, &
437 49461 : kind_number=ikind, element_symbol=element_symbol)
438 49461 : CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set)
439 122302 : IF (ASSOCIATED(orb_basis_set)) THEN
440 : CALL get_gto_basis_set(gto_basis_set=orb_basis_set, &
441 : nset=nset, nshell=nshell, l=lshell, &
442 49461 : cgf_symbol=cgf_symbol, sgf_symbol=sgf_symbol)
443 49461 : isgf = 1
444 145988 : DO iset = 1, nset
445 244575 : DO ishell = 1, nshell(iset)
446 98587 : l = lshell(ishell, iset)
447 530820 : DO iso = 1, MERGE(nco(l), nso(l), my_cartesian_basis)
448 237123 : IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
449 237123 : IF (omit_headers) THEN
450 : WRITE (UNIT=output_unit, FMT=fmtstr2) &
451 12818 : (matrix(irow, jcol), jcol=from, to)
452 : ELSE
453 233519 : IF (my_cartesian_basis) THEN
454 : WRITE (UNIT=output_unit, FMT=fmtstr2) &
455 4 : irow, iatom, element_symbol, cgf_symbol(isgf), &
456 24 : (matrix(irow, jcol), jcol=from, to)
457 : ELSE
458 : WRITE (UNIT=output_unit, FMT=fmtstr2) &
459 233515 : irow, iatom, element_symbol, sgf_symbol(isgf), &
460 1244719 : (matrix(irow, jcol), jcol=from, to)
461 : END IF
462 : END IF
463 : END IF
464 237123 : isgf = isgf + 1
465 335710 : irow = irow + 1
466 : END DO
467 : END DO
468 : END DO
469 49461 : IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
470 26081 : WRITE (UNIT=output_unit, FMT="(A)")
471 : END IF
472 : ELSE
473 0 : DO iso = first_sgf(iatom), last_sgf(iatom)
474 0 : IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
475 0 : IF (omit_headers) THEN
476 : WRITE (UNIT=output_unit, FMT=fmtstr2) &
477 0 : (matrix(irow, jcol), jcol=from, to)
478 : ELSE
479 : WRITE (UNIT=output_unit, FMT=fmtstr2) &
480 0 : irow, iatom, element_symbol, " ", &
481 0 : (matrix(irow, jcol), jcol=from, to)
482 : END IF
483 : END IF
484 0 : irow = irow + 1
485 : END DO
486 0 : IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
487 0 : WRITE (UNIT=output_unit, FMT="(A)")
488 : END IF
489 : END IF
490 : END DO
491 : END DO
492 :
493 7953 : WRITE (UNIT=output_unit, FMT="(/)")
494 7953 : DEALLOCATE (first_sgf)
495 15906 : DEALLOCATE (last_sgf)
496 : END IF
497 :
498 15906 : CALL para_env%sync()
499 15906 : IF (output_unit > 0) CALL m_flush(output_unit)
500 :
501 31812 : END SUBROUTINE write_matrix_sym
502 :
503 : ! **************************************************************************************************
504 : !> \brief Write a matrix not necessarily symmetric (no index with atomic labels)
505 : !> \param matrix ...
506 : !> \param matrix_name ...
507 : !> \param before ...
508 : !> \param after ...
509 : !> \param para_env ...
510 : !> \param first_row ...
511 : !> \param last_row ...
512 : !> \param first_col ...
513 : !> \param last_col ...
514 : !> \param output_unit ...
515 : !> \param omit_headers Write only the matrix data, not the row/column headers
516 : !> \author Teodoro Laino [tlaino] - 10.2007 - University of Zurich
517 : ! **************************************************************************************************
518 0 : SUBROUTINE write_matrix_gen(matrix, matrix_name, before, after, para_env, &
519 : first_row, last_row, first_col, last_col, output_unit, omit_headers)
520 :
521 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: matrix
522 : CHARACTER(LEN=*), INTENT(IN) :: matrix_name
523 : INTEGER, INTENT(IN) :: before, after
524 : TYPE(mp_para_env_type), POINTER :: para_env
525 : INTEGER, INTENT(IN) :: first_row, last_row, first_col, &
526 : last_col, output_unit
527 : LOGICAL, INTENT(IN) :: omit_headers
528 :
529 : CHARACTER(LEN=25) :: fmtstr1
530 : CHARACTER(LEN=35) :: fmtstr2
531 : INTEGER :: from, icol, irow, jcol, left, ncol, &
532 : ndigits, right, to, width
533 :
534 0 : IF (output_unit > 0) THEN
535 0 : CALL m_flush(output_unit)
536 :
537 : ! *** Definition of the variable formats ***
538 0 : fmtstr1 = "(/,T2,23X, ( X,I5, X))"
539 0 : IF (omit_headers) THEN
540 0 : fmtstr2 = "(T2, (1X,F . ))"
541 : ELSE
542 0 : fmtstr2 = "(T2, I5, 18X, (1X,F . ))"
543 : END IF
544 :
545 : ! *** Write headline ***
546 0 : WRITE (UNIT=output_unit, FMT="(/,/,T2,A)") TRIM(matrix_name)
547 :
548 : ! *** Write the variable format strings ***
549 0 : ndigits = after
550 :
551 0 : width = before + ndigits + 3
552 0 : ncol = INT(56/width)
553 :
554 0 : right = MAX((ndigits - 2), 1)
555 0 : left = width - right - 5
556 :
557 0 : WRITE (UNIT=fmtstr1(11:12), FMT="(I2)") ncol
558 0 : WRITE (UNIT=fmtstr1(14:15), FMT="(I2)") left
559 0 : WRITE (UNIT=fmtstr1(21:22), FMT="(I2)") right
560 :
561 0 : IF (omit_headers) THEN
562 0 : WRITE (UNIT=fmtstr2(6:7), FMT="(I2)") ncol
563 0 : WRITE (UNIT=fmtstr2(13:14), FMT="(I2)") width - 1
564 0 : WRITE (UNIT=fmtstr2(16:17), FMT="(I2)") ndigits
565 : ELSE
566 0 : WRITE (UNIT=fmtstr2(22:23), FMT="(I2)") ncol
567 0 : WRITE (UNIT=fmtstr2(29:30), FMT="(I2)") width - 1
568 0 : WRITE (UNIT=fmtstr2(32:33), FMT="(I2)") ndigits
569 : END IF
570 :
571 : ! *** Write the matrix in the selected format ***
572 0 : DO icol = first_col, last_col, ncol
573 0 : from = icol
574 0 : to = MIN((from + ncol - 1), last_col)
575 0 : IF (.NOT. omit_headers) THEN
576 0 : WRITE (UNIT=output_unit, FMT=fmtstr1) (jcol, jcol=from, to)
577 : END IF
578 : irow = 1
579 0 : DO irow = first_row, last_row
580 0 : IF (omit_headers) THEN
581 : WRITE (UNIT=output_unit, FMT=fmtstr2) &
582 0 : irow, (matrix(irow, jcol), jcol=from, to)
583 : ELSE
584 : WRITE (UNIT=output_unit, FMT=fmtstr2) &
585 0 : (matrix(irow, jcol), jcol=from, to)
586 : END IF
587 : END DO
588 : END DO
589 :
590 0 : WRITE (UNIT=output_unit, FMT="(/)")
591 : END IF
592 :
593 0 : CALL para_env%sync()
594 0 : IF (output_unit > 0) CALL m_flush(output_unit)
595 :
596 0 : END SUBROUTINE write_matrix_gen
597 :
598 : ! **************************************************************************************************
599 : !> \brief Print the distribution of a sparse matrix.
600 : !> \param matrix ...
601 : !> \param output_unit ...
602 : !> \param para_env ...
603 : !> \par History
604 : !> Creation (25.06.2003,MK)
605 : ! **************************************************************************************************
606 92 : SUBROUTINE cp_dbcsr_write_matrix_dist(matrix, output_unit, para_env)
607 : TYPE(dbcsr_type) :: matrix
608 : INTEGER, INTENT(IN) :: output_unit
609 : TYPE(mp_para_env_type), POINTER :: para_env
610 :
611 : CHARACTER(LEN=*), PARAMETER :: routineN = 'cp_dbcsr_write_matrix_dist'
612 : LOGICAL, PARAMETER :: full_output = .FALSE.
613 :
614 : CHARACTER :: matrix_type
615 : CHARACTER(LEN=default_string_length) :: matrix_name
616 : INTEGER :: handle, ipe, mype, natom, nblock_max, &
617 : nelement_max, npe, nrow, tmp(2)
618 : INTEGER(KIND=int_8) :: nblock_sum, nblock_tot, nelement_sum
619 92 : INTEGER, ALLOCATABLE, DIMENSION(:) :: nblock, nelement
620 : LOGICAL :: ionode
621 : REAL(KIND=dp) :: occupation
622 : TYPE(cp_logger_type), POINTER :: logger
623 :
624 92 : NULLIFY (logger)
625 92 : logger => cp_get_default_logger()
626 :
627 92 : CALL timeset(routineN, handle)
628 :
629 92 : ionode = para_env%is_source()
630 92 : mype = para_env%mepos + 1
631 92 : npe = para_env%num_pe
632 :
633 : ! *** Allocate work storage ***
634 276 : ALLOCATE (nblock(npe))
635 : nblock(:) = 0
636 :
637 184 : ALLOCATE (nelement(npe))
638 : nelement(:) = 0
639 :
640 92 : nblock(mype) = dbcsr_get_num_blocks(matrix)
641 92 : nelement(mype) = dbcsr_get_data_size(matrix)
642 :
643 : CALL dbcsr_get_info(matrix=matrix, &
644 : name=matrix_name, &
645 : matrix_type=matrix_type, &
646 : nblkrows_total=natom, &
647 92 : nfullrows_total=nrow)
648 :
649 : IF (full_output) THEN
650 : ! XXXXXXXX should gather/scatter this on ionode
651 : CALL para_env%sum(nblock)
652 : CALL para_env%sum(nelement)
653 :
654 : nblock_sum = SUM(INT(nblock, KIND=int_8))
655 : nelement_sum = SUM(INT(nelement, KIND=int_8))
656 : ELSE
657 92 : nblock_sum = nblock(mype)
658 : nblock_max = nblock(mype)
659 92 : nelement_sum = nelement(mype)
660 : nelement_max = nelement(mype)
661 92 : CALL para_env%sum(nblock_sum)
662 92 : CALL para_env%sum(nelement_sum)
663 276 : tmp = [nblock_max, nelement_max]
664 92 : CALL para_env%max(tmp)
665 92 : nblock_max = tmp(1); nelement_max = tmp(2)
666 : END IF
667 :
668 92 : IF (matrix_type == dbcsr_type_symmetric .OR. &
669 : matrix_type == dbcsr_type_antisymmetric) THEN
670 92 : nblock_tot = INT(natom, KIND=int_8)*INT(natom + 1, KIND=int_8)/2
671 : ELSE
672 0 : nblock_tot = INT(natom, KIND=int_8)**2
673 : END IF
674 :
675 92 : occupation = -1.0_dp
676 92 : IF (nblock_tot /= 0) occupation = 100.0_dp*REAL(nblock_sum, dp)/REAL(nblock_tot, dp)
677 :
678 92 : IF (ionode) THEN
679 : WRITE (UNIT=output_unit, FMT="(/,/,T2,A)") &
680 46 : "DISTRIBUTION OF THE "//TRIM(matrix_name)
681 : IF (full_output) THEN
682 : WRITE (UNIT=output_unit, FMT="(/,T3,A,/,/,(I9,T27,I10,T55,I10))") &
683 : "Process Number of matrix blocks Number of matrix elements", &
684 : (ipe - 1, nblock(ipe), nelement(ipe), ipe=1, npe)
685 : WRITE (UNIT=output_unit, FMT="(/,T7,A3,T27,I10,T55,I10)") &
686 : "Sum", nblock_sum, nelement_sum
687 : WRITE (UNIT=output_unit, FMT="(/,T7,A3,T27,I10,A,F5.1,A,T55,I10,A,F5.1,A)") &
688 : " of", nblock_tot, " (", occupation, " % occupation)"
689 : ELSE
690 46 : WRITE (UNIT=output_unit, FMT="(T15,A,T68,I13)") "Number of non-zero blocks:", nblock_sum
691 46 : WRITE (UNIT=output_unit, FMT="(T15,A,T75,F6.2)") "Percentage non-zero blocks:", occupation
692 46 : WRITE (UNIT=output_unit, FMT="(T15,A,T68,I13)") "Average number of blocks per CPU:", &
693 92 : (nblock_sum + npe - 1)/npe
694 46 : WRITE (UNIT=output_unit, FMT="(T15,A,T68,I13)") "Maximum number of blocks per CPU:", nblock_max
695 46 : WRITE (UNIT=output_unit, FMT="(T15,A,T68,I13)") "Average number of matrix elements per CPU:", &
696 92 : (nelement_sum + npe - 1)/npe
697 46 : WRITE (UNIT=output_unit, FMT="(T15,A,T68,I13)") "Maximum number of matrix elements per CPU:", &
698 92 : nelement_max
699 : END IF
700 : END IF
701 :
702 : ! *** Release work storage ***
703 92 : DEALLOCATE (nblock)
704 :
705 92 : DEALLOCATE (nelement)
706 :
707 92 : CALL timestop(handle)
708 :
709 184 : END SUBROUTINE cp_dbcsr_write_matrix_dist
710 :
711 : END MODULE cp_dbcsr_output
|
