(git:34ef472)
cp_dbcsr_output.F
Go to the documentation of this file.
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  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  REAL(kind=dp), DIMENSION(:, :), POINTER :: matrix
92  TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
93 
94  IF (.NOT. ASSOCIATED(blacs_matrix%matrix_struct)) RETURN
95  CALL cp_fm_get_info(blacs_matrix, name=matrix_name, nrow_global=nrow_global, &
96  ncol_global=ncol_global)
97 
98  ALLOCATE (matrix(nrow_global, ncol_global))
99  CALL cp_fm_get_submatrix(blacs_matrix, matrix)
100 
101  ! *** Get the matrix dimension and check the optional arguments ***
102  CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set)
103  CALL get_qs_kind_set(qs_kind_set=qs_kind_set, nsgf=nsgf)
104 
105  IF (PRESENT(first_row)) THEN
106  row1 = max(1, first_row)
107  ELSE
108  row1 = 1
109  END IF
110 
111  IF (PRESENT(last_row)) THEN
112  row2 = min(nsgf, last_row)
113  ELSE
114  row2 = nsgf
115  END IF
116 
117  IF (PRESENT(first_col)) THEN
118  col1 = max(1, first_col)
119  ELSE
120  col1 = 1
121  END IF
122 
123  IF (PRESENT(last_col)) THEN
124  col2 = min(nsgf, last_col)
125  ELSE
126  col2 = nsgf
127  END IF
128 
129  IF (PRESENT(omit_headers)) THEN
130  my_omit_headers = omit_headers
131  ELSE
132  my_omit_headers = .false.
133  END IF
134 
135  CALL write_matrix_sym(matrix, matrix_name, before, after, qs_env, para_env, &
136  row1, row2, col1, col2, output_unit, omit_headers=my_omit_headers)
137 
138  ! *** Release work storage ***
139  IF (ASSOCIATED(matrix)) THEN
140  DEALLOCATE (matrix)
141  END IF
142 
143  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  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  REAL(kind=dp), DIMENSION(:, :), POINTER :: matrix
177  TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
178 
179  NULLIFY (matrix)
180 
181  CALL copy_repl_dbcsr_to_repl_fm(sparse_matrix, matrix)
182 
183  CALL para_env%sum(matrix)
184 
185  SELECT CASE (dbcsr_get_matrix_type(sparse_matrix))
186  CASE (dbcsr_type_symmetric)
187  CALL symmetrize_matrix(matrix, "upper_to_lower")
188  print_sym = .true.
189  CASE (dbcsr_type_antisymmetric)
190  CALL symmetrize_matrix(matrix, "anti_upper_to_lower")
191  print_sym = .true.
192  CASE (dbcsr_type_no_symmetry)
193  print_sym = .false.
194  CASE DEFAULT
195  cpabort("WRONG")
196  END SELECT
197 
198  ! *** Get the matrix dimension and check the optional arguments ***
199  CALL get_qs_env(qs_env=qs_env, qs_kind_set=qs_kind_set)
200  dim_row = SIZE(matrix, 1)
201  dim_col = SIZE(matrix, 2)
202 
203  IF (PRESENT(first_row)) THEN
204  row1 = max(1, first_row)
205  ELSE
206  row1 = 1
207  END IF
208 
209  IF (PRESENT(last_row)) THEN
210  row2 = min(dim_row, last_row)
211  ELSE
212  row2 = dim_row
213  END IF
214 
215  IF (PRESENT(first_col)) THEN
216  col1 = max(1, first_col)
217  ELSE
218  col1 = 1
219  END IF
220 
221  IF (PRESENT(last_col)) THEN
222  col2 = min(dim_col, last_col)
223  ELSE
224  col2 = dim_col
225  END IF
226 
227  IF (PRESENT(scale)) THEN
228  matrix = matrix*scale
229  END IF
230 
231  IF (PRESENT(omit_headers)) THEN
232  my_omit_headers = omit_headers
233  ELSE
234  my_omit_headers = .false.
235  END IF
236 
237  CALL dbcsr_get_info(sparse_matrix, name=matrix_name)
238  IF (print_sym) THEN
239  CALL write_matrix_sym(matrix, matrix_name, before, after, qs_env, para_env, &
240  row1, row2, col1, col2, output_unit, my_omit_headers)
241  ELSE
242  CALL write_matrix_gen(matrix, matrix_name, before, after, para_env, &
243  row1, row2, col1, col2, output_unit, my_omit_headers)
244  END IF
245 
246  IF (ASSOCIATED(matrix)) THEN
247  DEALLOCATE (matrix)
248  END IF
249 
250  END SUBROUTINE cp_dbcsr_write_sparse_matrix
251 
252 ! **************************************************************************************************
253 !> \brief ...
254 !> \param sparse_matrix ...
255 !> \param fm ...
256 ! **************************************************************************************************
257  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  INTEGER, ALLOCATABLE, DIMENSION(:) :: c_offset, r_offset
267  INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size
268  REAL(kind=dp), DIMENSION(:, :), POINTER :: DATA
269  TYPE(dbcsr_iterator_type) :: iter
270 
271  CALL timeset(routinen, handle)
272 
273  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  nblkcols_total=nblkcols_total)
280 
281  !> this should be precomputed somewhere else
282  ALLOCATE (r_offset(nblkrows_total), c_offset(nblkcols_total))
283 
284  r_offset(1) = 1
285  DO row = 2, nblkrows_total
286  r_offset(row) = r_offset(row - 1) + row_blk_size(row - 1)
287  END DO
288  nr = sum(row_blk_size)
289  c_offset(1) = 1
290  DO col = 2, nblkcols_total
291  c_offset(col) = c_offset(col - 1) + col_blk_size(col - 1)
292  END DO
293  nc = sum(col_blk_size)
294  !<
295 
296  ALLOCATE (fm(nr, nc))
297 
298  fm(:, :) = 0.0_dp
299 
300  CALL dbcsr_iterator_start(iter, sparse_matrix)
301  DO WHILE (dbcsr_iterator_blocks_left(iter))
302  CALL dbcsr_iterator_next_block(iter, row, col, DATA, blk)
303  DO j = 1, SIZE(DATA, 2)
304  DO i = 1, SIZE(DATA, 1)
305  fm(r_offset(row) + i - 1, c_offset(col) + j - 1) = DATA(i, j)
306  END DO
307  END DO
308  END DO
309  CALL dbcsr_iterator_stop(iter)
310 
311  DEALLOCATE (r_offset, c_offset)
312 
313  CALL timestop(handle)
314 
315  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  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  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  INTEGER, ALLOCATABLE, DIMENSION(:) :: first_sgf, last_sgf
354  INTEGER, DIMENSION(:), POINTER :: nshell
355  INTEGER, DIMENSION(:, :), POINTER :: lshell
356  TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
357  TYPE(gto_basis_set_type), POINTER :: orb_basis_set
358  TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
359  TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
360 
361  IF (output_unit > 0) THEN
362  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  particle_set=particle_set)
368 
369  natom = SIZE(particle_set)
370 
371  CALL get_qs_kind_set(qs_kind_set=qs_kind_set, nsgf=nsgf)
372 
373  ALLOCATE (first_sgf(natom))
374  ALLOCATE (last_sgf(natom))
375  CALL get_particle_set(particle_set, qs_kind_set, &
376  first_sgf=first_sgf, &
377  last_sgf=last_sgf)
378 
379  ! *** Definition of the variable formats ***
380  fmtstr1 = "(/,T2,23X, ( X,I5, X))"
381  IF (omit_headers) THEN
382  fmtstr2 = "(T2, (1X,F . ))"
383  ELSE
384  fmtstr2 = "(T2,2I5,2X,A2,1X,A8, (1X,F . ))"
385  END IF
386 
387  ! *** Write headline ***
388  WRITE (unit=output_unit, fmt="(/,/,T2,A)") trim(matrix_name)
389 
390  ! *** Write the variable format strings ***
391  ndigits = after
392 
393  width = before + ndigits + 3
394  ncol = int(56/width)
395 
396  right = max((ndigits - 2), 1)
397  left = width - right - 5
398 
399  WRITE (unit=fmtstr1(11:12), fmt="(I2)") ncol
400  WRITE (unit=fmtstr1(14:15), fmt="(I2)") left
401  WRITE (unit=fmtstr1(21:22), fmt="(I2)") right
402 
403  IF (omit_headers) THEN
404  WRITE (unit=fmtstr2(6:7), fmt="(I2)") ncol
405  WRITE (unit=fmtstr2(13:14), fmt="(I2)") width - 1
406  WRITE (unit=fmtstr2(16:17), fmt="(I2)") ndigits
407  ELSE
408  WRITE (unit=fmtstr2(22:23), fmt="(I2)") ncol
409  WRITE (unit=fmtstr2(29:30), fmt="(I2)") width - 1
410  WRITE (unit=fmtstr2(32:33), fmt="(I2)") ndigits
411  END IF
412 
413  ! *** Write the matrix in the selected format ***
414  DO icol = first_col, last_col, ncol
415  from = icol
416  to = min((from + ncol - 1), last_col)
417  IF (.NOT. omit_headers) THEN
418  WRITE (unit=output_unit, fmt=fmtstr1) (jcol, jcol=from, to)
419  END IF
420  irow = 1
421  DO iatom = 1, natom
422  NULLIFY (orb_basis_set)
423  CALL get_atomic_kind(particle_set(iatom)%atomic_kind, &
424  kind_number=ikind, element_symbol=element_symbol)
425  CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set)
426  IF (ASSOCIATED(orb_basis_set)) THEN
427  CALL get_gto_basis_set(gto_basis_set=orb_basis_set, &
428  nset=nset, nshell=nshell, l=lshell, sgf_symbol=sgf_symbol)
429  isgf = 1
430  DO iset = 1, nset
431  DO ishell = 1, nshell(iset)
432  l = lshell(ishell, iset)
433  DO iso = 1, nso(l)
434  IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
435  IF (omit_headers) THEN
436  WRITE (unit=output_unit, fmt=fmtstr2) &
437  (matrix(irow, jcol), jcol=from, to)
438  ELSE
439  WRITE (unit=output_unit, fmt=fmtstr2) &
440  irow, iatom, element_symbol, sgf_symbol(isgf), &
441  (matrix(irow, jcol), jcol=from, to)
442  END IF
443  END IF
444  isgf = isgf + 1
445  irow = irow + 1
446  END DO
447  END DO
448  END DO
449  IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
450  WRITE (unit=output_unit, fmt="(A)")
451  END IF
452  ELSE
453  DO iso = first_sgf(iatom), last_sgf(iatom)
454  IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
455  IF (omit_headers) THEN
456  WRITE (unit=output_unit, fmt=fmtstr2) &
457  (matrix(irow, jcol), jcol=from, to)
458  ELSE
459  WRITE (unit=output_unit, fmt=fmtstr2) &
460  irow, iatom, element_symbol, " ", &
461  (matrix(irow, jcol), jcol=from, to)
462  END IF
463  END IF
464  irow = irow + 1
465  END DO
466  IF ((irow >= first_row) .AND. (irow <= last_row)) THEN
467  WRITE (unit=output_unit, fmt="(A)")
468  END IF
469  END IF
470  END DO
471  END DO
472 
473  WRITE (unit=output_unit, fmt="(/)")
474  DEALLOCATE (first_sgf)
475  DEALLOCATE (last_sgf)
476  END IF
477 
478  CALL para_env%sync()
479  IF (output_unit > 0) CALL m_flush(output_unit)
480 
481  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  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  IF (output_unit > 0) THEN
515  CALL m_flush(output_unit)
516 
517  ! *** Definition of the variable formats ***
518  fmtstr1 = "(/,T2,23X, ( X,I5, X))"
519  IF (omit_headers) THEN
520  fmtstr2 = "(T2, (1X,F . ))"
521  ELSE
522  fmtstr2 = "(T2, I5, 18X, (1X,F . ))"
523  END IF
524 
525  ! *** Write headline ***
526  WRITE (unit=output_unit, fmt="(/,/,T2,A)") trim(matrix_name)
527 
528  ! *** Write the variable format strings ***
529  ndigits = after
530 
531  width = before + ndigits + 3
532  ncol = int(56/width)
533 
534  right = max((ndigits - 2), 1)
535  left = width - right - 5
536 
537  WRITE (unit=fmtstr1(11:12), fmt="(I2)") ncol
538  WRITE (unit=fmtstr1(14:15), fmt="(I2)") left
539  WRITE (unit=fmtstr1(21:22), fmt="(I2)") right
540 
541  IF (omit_headers) THEN
542  WRITE (unit=fmtstr2(6:7), fmt="(I2)") ncol
543  WRITE (unit=fmtstr2(13:14), fmt="(I2)") width - 1
544  WRITE (unit=fmtstr2(16:17), fmt="(I2)") ndigits
545  ELSE
546  WRITE (unit=fmtstr2(22:23), fmt="(I2)") ncol
547  WRITE (unit=fmtstr2(29:30), fmt="(I2)") width - 1
548  WRITE (unit=fmtstr2(32:33), fmt="(I2)") ndigits
549  END IF
550 
551  ! *** Write the matrix in the selected format ***
552  DO icol = first_col, last_col, ncol
553  from = icol
554  to = min((from + ncol - 1), last_col)
555  IF (.NOT. omit_headers) THEN
556  WRITE (unit=output_unit, fmt=fmtstr1) (jcol, jcol=from, to)
557  END IF
558  irow = 1
559  DO irow = first_row, last_row
560  IF (omit_headers) THEN
561  WRITE (unit=output_unit, fmt=fmtstr2) &
562  irow, (matrix(irow, jcol), jcol=from, to)
563  ELSE
564  WRITE (unit=output_unit, fmt=fmtstr2) &
565  (matrix(irow, jcol), jcol=from, to)
566  END IF
567  END DO
568  END DO
569 
570  WRITE (unit=output_unit, fmt="(/)")
571  END IF
572 
573  CALL para_env%sync()
574  IF (output_unit > 0) CALL m_flush(output_unit)
575 
576  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  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  INTEGER, ALLOCATABLE, DIMENSION(:) :: nblock, nelement
600  LOGICAL :: ionode
601  REAL(kind=dp) :: occupation
602  TYPE(cp_logger_type), POINTER :: logger
603 
604  NULLIFY (logger)
605  logger => cp_get_default_logger()
606 
607  CALL timeset(routinen, handle)
608 
609  ionode = para_env%is_source()
610  mype = para_env%mepos + 1
611  npe = para_env%num_pe
612 
613  ! *** Allocate work storage ***
614  ALLOCATE (nblock(npe))
615  nblock(:) = 0
616 
617  ALLOCATE (nelement(npe))
618  nelement(:) = 0
619 
620  nblock(mype) = dbcsr_get_num_blocks(matrix)
621  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  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  nblock_sum = nblock(mype)
638  nblock_max = nblock(mype)
639  nelement_sum = nelement(mype)
640  nelement_max = nelement(mype)
641  CALL para_env%sum(nblock_sum)
642  CALL para_env%sum(nelement_sum)
643  tmp = (/nblock_max, nelement_max/)
644  CALL para_env%max(tmp)
645  nblock_max = tmp(1); nelement_max = tmp(2)
646  END IF
647 
648  IF (matrix_type == dbcsr_type_symmetric .OR. &
649  matrix_type == dbcsr_type_antisymmetric) THEN
650  nblock_tot = int(natom, kind=int_8)*int(natom + 1, kind=int_8)/2
651  ELSE
652  nblock_tot = int(natom, kind=int_8)**2
653  END IF
654 
655  occupation = -1.0_dp
656  IF (nblock_tot .NE. 0) occupation = 100.0_dp*real(nblock_sum, dp)/real(nblock_tot, dp)
657 
658  IF (ionode) THEN
659  WRITE (unit=output_unit, fmt="(/,/,T2,A)") &
660  "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  WRITE (unit=output_unit, fmt="(T15,A,T68,I13)") "Number of non-zero blocks:", nblock_sum
671  WRITE (unit=output_unit, fmt="(T15,A,T75,F6.2)") "Percentage non-zero blocks:", occupation
672  WRITE (unit=output_unit, fmt="(T15,A,T68,I13)") "Average number of blocks per CPU:", &
673  (nblock_sum + npe - 1)/npe
674  WRITE (unit=output_unit, fmt="(T15,A,T68,I13)") "Maximum number of blocks per CPU:", nblock_max
675  WRITE (unit=output_unit, fmt="(T15,A,T68,I13)") "Average number of matrix elements per CPU:", &
676  (nelement_sum + npe - 1)/npe
677  WRITE (unit=output_unit, fmt="(T15,A,T68,I13)") "Maximum number of matrix elements per CPU:", &
678  nelement_max
679  END IF
680  END IF
681 
682  ! *** Release work storage ***
683  DEALLOCATE (nblock)
684 
685  DEALLOCATE (nelement)
686 
687  CALL timestop(handle)
688 
689  END SUBROUTINE cp_dbcsr_write_matrix_dist
690 
691 END MODULE cp_dbcsr_output
atomic_kind_types
Define the atomic kind types and their sub types.
Definition: atomic_kind_types.F:23
atomic_kind_types::get_atomic_kind
subroutine, public get_atomic_kind(atomic_kind, fist_potential, element_symbol, name, mass, kind_number, natom, atom_list, rcov, rvdw, z, qeff, apol, cpol, mm_radius, shell, shell_active, damping)
Get attributes of an atomic kind.
Definition: atomic_kind_types.F:138
basis_set_types
Definition: basis_set_types.F:15
basis_set_types::get_gto_basis_set
subroutine, public get_gto_basis_set(gto_basis_set, name, aliases, norm_type, kind_radius, ncgf, nset, nsgf, cgf_symbol, sgf_symbol, norm_cgf, set_radius, lmax, lmin, lx, ly, lz, m, ncgf_set, npgf, nsgf_set, nshell, cphi, pgf_radius, sphi, scon, zet, first_cgf, first_sgf, l, last_cgf, last_sgf, n, gcc, maxco, maxl, maxpgf, maxsgf_set, maxshell, maxso, nco_sum, npgf_sum, nshell_sum, maxder, short_kind_radius)
...
Definition: basis_set_types.F:615
cp_dbcsr_output
DBCSR output in CP2K.
Definition: cp_dbcsr_output.F:17
cp_dbcsr_output::write_fm_with_basis_info
subroutine, public write_fm_with_basis_info(blacs_matrix, before, after, qs_env, para_env, first_row, last_row, first_col, last_col, output_unit, omit_headers)
Print a spherical matrix of blacs type.
Definition: cp_dbcsr_output.F:78
cp_dbcsr_output::cp_dbcsr_write_matrix_dist
subroutine, public cp_dbcsr_write_matrix_dist(matrix, output_unit, para_env)
Print the distribution of a sparse matrix.
Definition: cp_dbcsr_output.F:587
cp_dbcsr_output::cp_dbcsr_write_sparse_matrix
subroutine, public cp_dbcsr_write_sparse_matrix(sparse_matrix, before, after, qs_env, para_env, first_row, last_row, first_col, last_col, scale, output_unit, omit_headers)
...
Definition: cp_dbcsr_output.F:163
cp_fm_types
represent a full matrix distributed on many processors
Definition: cp_fm_types.F:15
cp_fm_types::cp_fm_get_info
subroutine, public cp_fm_get_info(matrix, name, nrow_global, ncol_global, nrow_block, ncol_block, nrow_local, ncol_local, row_indices, col_indices, local_data, context, nrow_locals, ncol_locals, matrix_struct, para_env)
returns all kind of information about the full matrix
Definition: cp_fm_types.F:1016
cp_fm_types::cp_fm_get_submatrix
subroutine, public cp_fm_get_submatrix(fm, target_m, start_row, start_col, n_rows, n_cols, transpose)
gets a submatrix of a full matrix op(target_m)(1:n_rows,1:n_cols) =fm(start_row:start_row+n_rows,...
Definition: cp_fm_types.F:901
cp_log_handling
various routines to log and control the output. The idea is that decisions about where to log should ...
Definition: cp_log_handling.F:41
cp_log_handling::cp_get_default_logger
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
Definition: cp_log_handling.F:234
kinds
Defines the basic variable types.
Definition: kinds.F:23
kinds::int_8
integer, parameter, public int_8
Definition: kinds.F:54
kinds::dp
integer, parameter, public dp
Definition: kinds.F:34
kinds::default_string_length
integer, parameter, public default_string_length
Definition: kinds.F:57
machine
Machine interface based on Fortran 2003 and POSIX.
Definition: machine.F:17
machine::m_flush
subroutine, public m_flush(lunit)
flushes units if the &GLOBAL flag is set accordingly
Definition: machine.F:106
mathlib
Collection of simple mathematical functions and subroutines.
Definition: mathlib.F:15
mathlib::symmetrize_matrix
subroutine, public symmetrize_matrix(a, option)
Symmetrize the matrix a.
Definition: mathlib.F:1208
message_passing
Interface to the message passing library MPI.
Definition: message_passing.F:23
orbital_pointers
Provides Cartesian and spherical orbital pointers and indices.
Definition: orbital_pointers.F:15
orbital_pointers::nso
integer, dimension(:), allocatable, public nso
Definition: orbital_pointers.F:42
particle_methods
Define methods related to particle_type.
Definition: particle_methods.F:14
particle_methods::get_particle_set
subroutine, public get_particle_set(particle_set, qs_kind_set, first_sgf, last_sgf, nsgf, nmao, basis)
Get the components of a particle set.
Definition: particle_methods.F:98
particle_types
Define the data structure for the particle information.
Definition: particle_types.F:19
qs_environment_types
Definition: qs_environment_types.F:14
qs_environment_types::get_qs_env
subroutine, public get_qs_env(qs_env, atomic_kind_set, qs_kind_set, cell, super_cell, cell_ref, use_ref_cell, kpoints, dft_control, mos, sab_orb, sab_all, qmmm, qmmm_periodic, sac_ae, sac_ppl, sac_lri, sap_ppnl, sab_vdw, sab_scp, sap_oce, sab_lrc, sab_se, sab_xtbe, sab_tbe, sab_core, sab_xb, sab_xtb_nonbond, sab_almo, sab_kp, sab_kp_nosym, particle_set, energy, force, matrix_h, matrix_h_im, matrix_ks, matrix_ks_im, matrix_vxc, run_rtp, rtp, matrix_h_kp, matrix_h_im_kp, matrix_ks_kp, matrix_ks_im_kp, matrix_vxc_kp, kinetic_kp, matrix_s_kp, matrix_w_kp, matrix_s_RI_aux_kp, matrix_s, matrix_s_RI_aux, matrix_w, matrix_p_mp2, matrix_p_mp2_admm, rho, rho_xc, pw_env, ewald_env, ewald_pw, active_space, mpools, input, para_env, blacs_env, scf_control, rel_control, kinetic, qs_charges, vppl, rho_core, rho_nlcc, rho_nlcc_g, ks_env, ks_qmmm_env, wf_history, scf_env, local_particles, local_molecules, distribution_2d, dbcsr_dist, molecule_kind_set, molecule_set, subsys, cp_subsys, oce, local_rho_set, rho_atom_set, task_list, task_list_soft, rho0_atom_set, rho0_mpole, rhoz_set, ecoul_1c, rho0_s_rs, rho0_s_gs, do_kpoints, has_unit_metric, requires_mo_derivs, mo_derivs, mo_loc_history, nkind, natom, nelectron_total, nelectron_spin, efield, neighbor_list_id, linres_control, xas_env, virial, cp_ddapc_env, cp_ddapc_ewald, outer_scf_history, outer_scf_ihistory, x_data, et_coupling, dftb_potential, results, se_taper, se_store_int_env, se_nddo_mpole, se_nonbond_env, admm_env, lri_env, lri_density, exstate_env, ec_env, dispersion_env, gcp_env, vee, rho_external, external_vxc, mask, mp2_env, bs_env, kg_env, WannierCentres, atprop, ls_scf_env, do_transport, transport_env, v_hartree_rspace, s_mstruct_changed, rho_changed, potential_changed, forces_up_to_date, mscfg_env, almo_scf_env, gradient_history, variable_history, embed_pot, spin_embed_pot, polar_env, mos_last_converged, rhs)
Get the QUICKSTEP environment.
Definition: qs_environment_types.F:502
qs_kind_types
Define the quickstep kind type and their sub types.
Definition: qs_kind_types.F:23
qs_kind_types::get_qs_kind
subroutine, public get_qs_kind(qs_kind, basis_set, basis_type, ncgf, nsgf, all_potential, tnadd_potential, gth_potential, sgp_potential, upf_potential, se_parameter, dftb_parameter, xtb_parameter, dftb3_param, zeff, elec_conf, mao, lmax_dftb, alpha_core_charge, ccore_charge, core_charge, core_charge_radius, paw_proj_set, paw_atom, hard_radius, hard0_radius, max_rad_local, covalent_radius, vdw_radius, gpw_r3d_rs_type_forced, harmonics, max_iso_not0, max_s_harm, grid_atom, ngrid_ang, ngrid_rad, lmax_rho0, dft_plus_u_atom, l_of_dft_plus_u, n_of_dft_plus_u, u_minus_j, U_of_dft_plus_u, J_of_dft_plus_u, alpha_of_dft_plus_u, beta_of_dft_plus_u, J0_of_dft_plus_u, occupation_of_dft_plus_u, dispersion, bs_occupation, magnetization, no_optimize, addel, laddel, naddel, orbitals, max_scf, eps_scf, smear, u_ramping, u_minus_j_target, eps_u_ramping, init_u_ramping_each_scf, reltmat, ghost, floating, name, element_symbol, pao_basis_size, pao_potentials, pao_descriptors, nelec)
Get attributes of an atomic kind.
Definition: qs_kind_types.F:451
qs_kind_types::get_qs_kind_set
subroutine, public get_qs_kind_set(qs_kind_set, all_potential_present, tnadd_potential_present, gth_potential_present, sgp_potential_present, paw_atom_present, dft_plus_u_atom_present, maxcgf, maxsgf, maxco, maxco_proj, maxgtops, maxlgto, maxlprj, maxnset, maxsgf_set, ncgf, npgf, nset, nsgf, nshell, maxpol, maxlppl, maxlppnl, maxppnl, nelectron, maxder, max_ngrid_rad, max_sph_harm, maxg_iso_not0, lmax_rho0, basis_rcut, basis_type, total_zeff_corr)
Get attributes of an atomic kind set.
Definition: qs_kind_types.F:864