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