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