1!--------------------------------------------------------------------------------------------------! 2! CP2K: A general program to perform molecular dynamics simulations ! 3! Copyright (C) 2000 - 2019 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