# 1 "/__w/dbcsr/dbcsr/src/ops/dbcsr_csr_conversions.F" 1 !--------------------------------------------------------------------------------------------------! ! Copyright (C) by the DBCSR developers group - All rights reserved ! ! This file is part of the DBCSR library. ! ! ! ! For information on the license, see the LICENSE file. ! ! For further information please visit https://dbcsr.cp2k.org ! ! SPDX-License-Identifier: GPL-2.0+ ! !--------------------------------------------------------------------------------------------------! MODULE dbcsr_csr_conversions !! DBCSR to CSR matrix format conversion USE dbcsr_block_access, ONLY: dbcsr_put_block USE dbcsr_data_methods, ONLY: dbcsr_data_clear_pointer, & dbcsr_data_init, & dbcsr_data_new, & dbcsr_data_release USE dbcsr_data_types, ONLY: dbcsr_type_complex_4, & dbcsr_type_complex_8, & dbcsr_type_real_4, & dbcsr_type_real_8, & dbcsr_type_real_default USE dbcsr_dist_methods, ONLY: dbcsr_distribution_col_dist, & dbcsr_distribution_mp, & dbcsr_distribution_new, & dbcsr_distribution_release USE dbcsr_iterator_operations, ONLY: dbcsr_iterator_blocks_left, & dbcsr_iterator_next_block, & dbcsr_iterator_start, & dbcsr_iterator_stop USE dbcsr_kinds, ONLY: default_string_length, & dp, & int_8, & real_4, & real_8, & sp USE dbcsr_methods, ONLY: & dbcsr_col_block_sizes, dbcsr_distribution, dbcsr_get_data_type, dbcsr_get_num_blocks, & dbcsr_get_nze, dbcsr_has_symmetry, dbcsr_name, dbcsr_nblkcols_total, dbcsr_nblkrows_total, & dbcsr_nfullrows_local, dbcsr_release, dbcsr_row_block_sizes, dbcsr_valid_index USE dbcsr_mp_methods, ONLY: dbcsr_mp_group, & dbcsr_mp_mynode, & dbcsr_mp_new, & dbcsr_mp_numnodes, & dbcsr_mp_release USE dbcsr_mpiwrap, ONLY: mp_environ, & mp_gather, & mp_recv, & mp_send, & mp_sum, mp_comm_type USE dbcsr_operations, ONLY: dbcsr_copy, & dbcsr_get_info, & dbcsr_set USE dbcsr_transformations, ONLY: dbcsr_complete_redistribute, & dbcsr_desymmetrize_deep USE dbcsr_types, ONLY: dbcsr_data_obj, & dbcsr_distribution_obj, & dbcsr_iterator, & dbcsr_mp_obj, & dbcsr_type USE dbcsr_work_operations, ONLY: dbcsr_create #include "base/dbcsr_base_uses.f90" IMPLICIT NONE PRIVATE CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_csr_conversions' LOGICAL, PARAMETER, PRIVATE :: careful_mod = .FALSE. INTEGER, PARAMETER, PUBLIC :: csr_dbcsr_blkrow_dist = 1, csr_eqrow_ceil_dist = 2, csr_eqrow_floor_dist = 3 TYPE csr_mapping_data !! Mapping data relating local CSR indices to local indices of a block-row !! distributed (BRD) DBCSR matrix, and containing the block structure !! of the original DBCSR matrix from which the CSR matrix was created. PRIVATE INTEGER, DIMENSION(:), POINTER :: csr_to_brd_ind => NULL(), & brd_to_csr_ind => NULL() !! csr_to_brd_ind(csr_ind) gives the location of a matrix element with CSR index csr_ind (location in nzval_local) inside !! the data_area of the corresponding BRD matrix. If an element of the DBCSR matrix is treated as 0 in the CSR format, the !! index of this value is not in csr_to_brd_ind. !! same as csr_to_brd_ind but inverse mapping. If a given DBCSR index dbcsr_ind points to a zero element, then !! brd_to_csr_ind(dbcsr_ind) is -1. TYPE(dbcsr_type) :: brd_mat !! DBCSR BRD matrix acting as an intermediate step in any conversion from and to DBCSR format. LOGICAL :: has_dbcsr_block_data = .FALSE. !! whether dbcsr_* fields are defined INTEGER :: dbcsr_nblkcols_total, & dbcsr_nblkrows_total, & dbcsr_nblks_local !! data from original DBCSR matrix (not block-row distributed), !! representing the original block structure. INTEGER, DIMENSION(:), POINTER :: dbcsr_row_p, dbcsr_col_i, & dbcsr_row_blk_size, dbcsr_col_blk_size !! data from original DBCSR matrix (not block-row distributed), !! representing the original block structure. END TYPE TYPE csr_data_area_type !! Data type of CSR matrices REAL(KIND=real_4), DIMENSION(:), POINTER :: r_sp => Null() !! real, single precision data array REAL(KIND=real_8), DIMENSION(:), POINTER :: r_dp => Null() !! real, double precision data array COMPLEX(KIND=real_4), DIMENSION(:), POINTER :: c_sp => Null() !! complex, double precision data array COMPLEX(KIND=real_8), DIMENSION(:), POINTER :: c_dp => Null() INTEGER :: data_type = -1 !! data type of CSR matrix END TYPE TYPE csr_type !! Type for CSR matrices INTEGER :: nrows_total, ncols_total, & nze_local, nrows_local !! total number of rows !! total number of columns !! local number of nonzero elements !! local number of rows TYPE(mp_comm_type) :: mp_group !! message-passing group ID INTEGER(KIND=int_8) :: nze_total !! total number of nonzero elements INTEGER, DIMENSION(:), POINTER :: rowptr_local => NULL(), & colind_local => NULL(), & nzerow_local => NULL() !! indices of elements inside nzval_local starting a row !! column indices of elements inside nzval_local TYPE(csr_data_area_type) :: nzval_local !! values of local non-zero elements, row-wise ordering. TYPE(csr_mapping_data) :: dbcsr_mapping !! mapping data relating indices of nzval_local to indices of a block-row distributed DBCSR matrix LOGICAL :: has_mapping = .FALSE. !! whether dbcsr_mapping is defined LOGICAL :: valid = .FALSE. !! whether essential data (excluding dbcsr_mapping) is completely allocated LOGICAL :: has_indices = .FALSE. !! whether rowptr_local and colind_local are defined END TYPE csr_type TYPE csr_p_type TYPE(csr_type), POINTER :: csr_mat END TYPE csr_p_type PUBLIC :: csr_type, csr_p_type, convert_csr_to_dbcsr, & csr_create_from_dbcsr, & csr_destroy, & convert_dbcsr_to_csr, & csr_create_new, csr_create_template, & csr_print_sparsity, dbcsr_to_csr_filter, & csr_write INTERFACE csr_create MODULE PROCEDURE csr_create_new, csr_create_template END INTERFACE CONTAINS SUBROUTINE csr_create_new(csr_mat, nrows_total, ncols_total, nze_total, & nze_local, nrows_local, mp_group, data_type) !! Create a new CSR matrix and allocate all internal data (excluding dbcsr_mapping) TYPE(csr_type), INTENT(OUT) :: csr_mat !! CSR matrix to return INTEGER, INTENT(IN) :: nrows_total, ncols_total !! total number of rows !! total number of columns INTEGER(KIND=int_8) :: nze_total !! total number of non-zero elements INTEGER, INTENT(IN) :: nze_local, nrows_local !! local number of non-zero elements !! local number of rows TYPE(mp_comm_type), INTENT(IN) :: mp_group INTEGER, INTENT(IN), OPTIONAL :: data_type !! data type of the CSR matrix (default real double prec.) CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_create_new' INTEGER :: handle CALL timeset(routineN, handle) IF (nrows_total .LT. nrows_local) & DBCSR_ABORT("local number of rows must not exceed total number of rows") IF (nze_total .LT. nze_local) CALL dbcsr_abort(__LOCATION__, "local number of non-zero "// & "elements must not exceed total number of non-zero elements") IF (INT(nrows_total, kind=int_8)*INT(ncols_total, kind=int_8) .LT. nze_total) & DBCSR_ABORT("Total number of non-zero elements must not exceed total matrix size") IF (INT(nrows_local, kind=int_8)*INT(ncols_total, kind=int_8) .LT. nze_local) & DBCSR_ABORT("Local number of non-zero elements must not exceed local matrix size") csr_mat%ncols_total = ncols_total csr_mat%nrows_total = nrows_total csr_mat%nze_total = nze_total csr_mat%nze_local = nze_local ALLOCATE (csr_mat%colind_local(nze_local)) csr_mat%nrows_local = nrows_local ALLOCATE (csr_mat%rowptr_local(nrows_local + 1)) ALLOCATE (csr_mat%nzerow_local(nrows_local)) IF (PRESENT(data_type)) THEN csr_mat%nzval_local%data_type = data_type ELSE csr_mat%nzval_local%data_type = dbcsr_type_real_default END IF SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) ALLOCATE (csr_mat%nzval_local%r_sp(nze_local)) CASE (dbcsr_type_real_8) ALLOCATE (csr_mat%nzval_local%r_dp(nze_local)) CASE (dbcsr_type_complex_4) ALLOCATE (csr_mat%nzval_local%c_sp(nze_local)) CASE (dbcsr_type_complex_8) ALLOCATE (csr_mat%nzval_local%c_dp(nze_local)) CASE DEFAULT DBCSR_ABORT("Invalid matrix type") END SELECT csr_mat%mp_group = mp_group csr_mat%valid = .TRUE. csr_mat%has_mapping = .FALSE. csr_mat%has_indices = .FALSE. CALL timestop(handle) END SUBROUTINE csr_create_new SUBROUTINE csr_create_template(matrix_b, matrix_a) !! Create a new CSR matrix and allocate all internal data using !! an existing CSR matrix. Copies the indices but no actual matrix data. TYPE(csr_type), INTENT(OUT) :: matrix_b !! Target CSR matrix TYPE(csr_type), INTENT(IN) :: matrix_a !! Source CSR matrix CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_create_template' INTEGER :: handle TYPE(csr_mapping_data) :: map CALL timeset(routineN, handle) IF (.NOT. matrix_a%valid) & DBCSR_ABORT("Source CSR matrix must be created.") CALL csr_create_new(matrix_b, matrix_a%nrows_total, matrix_a%ncols_total, & matrix_a%nze_total, matrix_a%nze_local, matrix_a%nrows_local, & matrix_a%mp_group, matrix_a%nzval_local%data_type) matrix_b%mp_group = matrix_a%mp_group matrix_b%has_mapping = matrix_a%has_mapping matrix_b%has_indices = matrix_a%has_indices IF (matrix_a%has_indices) THEN matrix_b%rowptr_local = matrix_a%rowptr_local matrix_b%nzerow_local = matrix_a%nzerow_local matrix_b%colind_local = matrix_a%colind_local END IF IF (matrix_a%has_mapping) THEN map = matrix_a%dbcsr_mapping ALLOCATE (matrix_b%dbcsr_mapping%csr_to_brd_ind(SIZE(map%csr_to_brd_ind))) ALLOCATE (matrix_b%dbcsr_mapping%brd_to_csr_ind(SIZE(map%brd_to_csr_ind))) matrix_b%dbcsr_mapping%csr_to_brd_ind = map%csr_to_brd_ind matrix_b%dbcsr_mapping%brd_to_csr_ind = map%brd_to_csr_ind matrix_b%dbcsr_mapping%has_dbcsr_block_data = map%has_dbcsr_block_data IF (matrix_b%dbcsr_mapping%has_dbcsr_block_data) THEN matrix_b%dbcsr_mapping%dbcsr_nblkcols_total = map%dbcsr_nblkcols_total matrix_b%dbcsr_mapping%dbcsr_nblkrows_total = map%dbcsr_nblkrows_total ALLOCATE (matrix_b%dbcsr_mapping%dbcsr_row_blk_size(map%dbcsr_nblkrows_total)) ALLOCATE (matrix_b%dbcsr_mapping%dbcsr_col_blk_size(map%dbcsr_nblkcols_total)) ALLOCATE (matrix_b%dbcsr_mapping%dbcsr_row_p(map%dbcsr_nblkrows_total + 1)) ALLOCATE (matrix_b%dbcsr_mapping%dbcsr_col_i(map%dbcsr_nblks_local)) matrix_b%dbcsr_mapping%dbcsr_nblks_local = map%dbcsr_nblks_local matrix_b%dbcsr_mapping%dbcsr_row_p = map%dbcsr_row_p matrix_b%dbcsr_mapping%dbcsr_col_i = map%dbcsr_col_i matrix_b%dbcsr_mapping%dbcsr_row_blk_size = map%dbcsr_row_blk_size matrix_b%dbcsr_mapping%dbcsr_col_blk_size = map%dbcsr_col_blk_size END IF CALL dbcsr_copy(matrix_b%dbcsr_mapping%brd_mat, map%brd_mat) matrix_b%valid = .TRUE. END IF CALL timestop(handle) END SUBROUTINE csr_create_template SUBROUTINE csr_create_nzerow(csr_mat, nzerow) !! create a vector containing the number of non-zero elements in each !! row of a CSR matrix TYPE(csr_type), INTENT(IN) :: csr_mat !! CSR matrix INTEGER, DIMENSION(:), INTENT(INOUT), POINTER :: nzerow !! number of non-zero elements in each row CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_create_nzerow' INTEGER :: handle, k CALL timeset(routineN, handle) IF (.NOT. csr_mat%valid) & DBCSR_ABORT("CSR matrix must be created.") DO k = 1, csr_mat%nrows_local nzerow(k) = csr_mat%rowptr_local(k + 1) - csr_mat%rowptr_local(k) END DO CALL timestop(handle) END SUBROUTINE csr_create_nzerow SUBROUTINE csr_destroy(csr_mat) !! destroy a CSR matrix TYPE(csr_type), INTENT(INOUT) :: csr_mat CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_destroy' INTEGER :: handle TYPE(csr_mapping_data) :: map CALL timeset(routineN, handle) IF (.NOT. csr_mat%valid) & DBCSR_ABORT("CSR matrix must be created before destroying it.") IF (ASSOCIATED(csr_mat%rowptr_local)) DEALLOCATE (csr_mat%rowptr_local) IF (ASSOCIATED(csr_mat%nzerow_local)) DEALLOCATE (csr_mat%nzerow_local) IF (ASSOCIATED(csr_mat%colind_local)) DEALLOCATE (csr_mat%colind_local) IF (csr_mat%has_mapping) THEN map = csr_mat%dbcsr_mapping IF (ASSOCIATED(map%csr_to_brd_ind)) & DEALLOCATE (map%csr_to_brd_ind) IF (ASSOCIATED(map%brd_to_csr_ind)) & DEALLOCATE (map%brd_to_csr_ind) IF (ASSOCIATED(map%dbcsr_row_blk_size)) & DEALLOCATE (map%dbcsr_row_blk_size) IF (ASSOCIATED(map%dbcsr_col_blk_size)) & DEALLOCATE (map%dbcsr_col_blk_size) IF (ASSOCIATED(map%dbcsr_row_p)) & DEALLOCATE (map%dbcsr_row_p) IF (ASSOCIATED(map%dbcsr_col_i)) & DEALLOCATE (map%dbcsr_col_i) CALL dbcsr_release(map%brd_mat) END IF IF (ASSOCIATED(csr_mat%nzval_local%r_dp)) & DEALLOCATE (csr_mat%nzval_local%r_dp) IF (ASSOCIATED(csr_mat%nzval_local%r_sp)) & DEALLOCATE (csr_mat%nzval_local%r_sp) IF (ASSOCIATED(csr_mat%nzval_local%c_sp)) & DEALLOCATE (csr_mat%nzval_local%c_sp) IF (ASSOCIATED(csr_mat%nzval_local%c_dp)) & DEALLOCATE (csr_mat%nzval_local%c_dp) csr_mat%has_mapping = .FALSE. csr_mat%valid = .FALSE. csr_mat%dbcsr_mapping%has_dbcsr_block_data = .FALSE. csr_mat%has_indices = .FALSE. csr_mat%nzval_local%data_type = -1 CALL timestop(handle) END SUBROUTINE csr_destroy SUBROUTINE csr_create_from_brd(brd_mat, csr_mat, csr_sparsity_brd) !! Allocate the internals of a CSR matrix using data from a block-row !! distributed DBCSR matrix TYPE(dbcsr_type), INTENT(IN) :: brd_mat !! block-row-distributed DBCSR matrix TYPE(csr_type), INTENT(OUT) :: csr_mat !! CSR matrix TYPE(dbcsr_type), INTENT(IN) :: csr_sparsity_brd !! BRD matrix representing sparsity pattern of CSR matrix CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_create_from_brd' INTEGER :: data_type, handle, & nfullcols_total, nfullrows, & nfullrows_total, nze_local INTEGER(KIND=int_8) :: nze_total INTEGER, DIMENSION(:), POINTER :: cdist, csr_index, dbcsr_index TYPE(dbcsr_distribution_obj) :: dist_current TYPE(mp_comm_type) :: mp_group CALL timeset(routineN, handle) NULLIFY (dbcsr_index, csr_index, cdist) dist_current = dbcsr_distribution(brd_mat) mp_group = dbcsr_mp_group(dbcsr_distribution_mp(dist_current)) cdist => dbcsr_distribution_col_dist(dist_current) IF (ANY(cdist .NE. 0)) & DBCSR_ABORT("DBCSR matrix not block-row distributed.") ! Calculate mapping between BRD and CSR indices CALL csr_get_dbcsr_mapping(brd_mat, dbcsr_index, csr_index, nze_local, & csr_sparsity_brd) CALL dbcsr_get_info(brd_mat, nfullrows_total=nfullrows_total, & nfullcols_total=nfullcols_total) ! Sum up local number of non-zero elements to get total number nze_total = nze_local CALL mp_sum(nze_total, mp_group) nfullrows = dbcsr_nfullrows_local(brd_mat) data_type = dbcsr_get_data_type(brd_mat) ! Allocate CSR matrix CALL csr_create_new(csr_mat, nfullrows_total, nfullcols_total, nze_total, & nze_local, nfullrows, mp_group, data_type) csr_mat%dbcsr_mapping%brd_to_csr_ind => csr_index csr_mat%dbcsr_mapping%csr_to_brd_ind => dbcsr_index csr_mat%has_mapping = .TRUE. csr_mat%dbcsr_mapping%brd_mat = brd_mat CALL timestop(handle) END SUBROUTINE csr_create_from_brd SUBROUTINE csr_get_dbcsr_mapping(brd_mat, dbcsr_index, csr_index, csr_nze_local, & csr_sparsity_brd) !! create the mapping information between a block-row distributed DBCSR !! matrix and the corresponding CSR matrix TYPE(dbcsr_type), INTENT(IN) :: brd_mat !! the block-row distributed DBCSR matrix INTEGER, DIMENSION(:), INTENT(OUT), POINTER :: dbcsr_index, csr_index !! csr to dbcsr index mapping !! dbcsr to csr index mapping INTEGER, INTENT(OUT) :: csr_nze_local !! number of local non-zero elements TYPE(dbcsr_type), INTENT(IN) :: csr_sparsity_brd !! sparsity of CSR matrix represented in BRD format CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_get_dbcsr_mapping' INTEGER :: blk, blkcol, blkrow, col_blk_size, csr_ind, data_type, dbcsr_ind, el_sum, & fullcol_sum_blkrow, handle, l, m, n, nblkrows_total, nze, prev_blk, prev_blkrow, & prev_row_blk_size, row_blk_offset, row_blk_size INTEGER, ALLOCATABLE, DIMENSION(:) :: csr_nze, nfullcol_blkrow INTEGER, DIMENSION(:), POINTER :: dbcsr_index_nozeroes LOGICAL :: tr TYPE(dbcsr_iterator) :: iter CALL timeset(routineN, handle) m = 0 dbcsr_ind = 0 fullcol_sum_blkrow = 0 NULLIFY (dbcsr_index, csr_index) CALL dbcsr_get_info(brd_mat, nblkrows_total=nblkrows_total) nze = dbcsr_get_nze(brd_mat) ALLOCATE (nfullcol_blkrow(nblkrows_total)) ALLOCATE (dbcsr_index(nze)) ALLOCATE (csr_index(nze)) CALL dbcsr_iterator_start(iter, brd_mat, read_only=.TRUE.) nfullcol_blkrow = 0 ! number of non-zero full columns in each block row prev_blk = 0 DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, blkrow, blkcol, blk, transposed=tr, & col_size=col_blk_size) IF (blk /= prev_blk + 1) & DBCSR_ABORT("iterator is required to traverse the blocks in a row-wise fashion") prev_blk = blk nfullcol_blkrow(blkrow) = nfullcol_blkrow(blkrow) + col_blk_size IF (tr) & DBCSR_ABORT("DBCSR block data must not be transposed") END DO CALL dbcsr_iterator_stop(iter) el_sum = 0 ! number of elements above current block row prev_blkrow = 0 ! store number and size of previous block row prev_row_blk_size = 0 CALL dbcsr_iterator_start(iter, brd_mat, read_only=.TRUE.) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, blkrow, blkcol, blk, transposed=tr, & row_size=row_blk_size, col_size=col_blk_size, row_offset=row_blk_offset) IF (blkrow .GT. prev_blkrow) THEN ! new block row IF (prev_blkrow .GT. 0) THEN el_sum = el_sum + nfullcol_blkrow(prev_blkrow)*prev_row_blk_size END IF ! number of non-zero full columns on the left of current block: fullcol_sum_blkrow = 0 dbcsr_ind = el_sum END IF DO n = 1, col_blk_size !nr of columns DO m = 1, row_blk_size !nr of rows dbcsr_ind = dbcsr_ind + 1 csr_ind = (m - 1)*nfullcol_blkrow(blkrow) + fullcol_sum_blkrow + n + el_sum dbcsr_index(csr_ind) = dbcsr_ind csr_index(dbcsr_ind) = csr_ind END DO END DO fullcol_sum_blkrow = fullcol_sum_blkrow + col_blk_size prev_blkrow = blkrow prev_row_blk_size = row_blk_size END DO CALL dbcsr_iterator_stop(iter) ! remove BRD zero elements from CSR format data_type = dbcsr_get_data_type(csr_sparsity_brd) ALLOCATE (csr_nze(nze)) SELECT CASE (data_type) CASE (dbcsr_type_real_4) csr_nze(:) = INT(csr_sparsity_brd%data_area%d%r_sp(1:nze)) CASE (dbcsr_type_real_8) csr_nze(:) = INT(csr_sparsity_brd%data_area%d%r_dp(1:nze)) CASE DEFAULT DBCSR_ABORT("CSR sparsity matrix must have a real datatype") END SELECT IF (ANY(csr_nze .EQ. 0)) THEN ALLOCATE (dbcsr_index_nozeroes(SUM(csr_nze))) m = 0 ! csr index if zeroes are excluded from CSR data DO l = 1, nze ! csr index if zeroes are included in CSR data IF (csr_nze(dbcsr_index(l)) .EQ. 0) THEN csr_index(dbcsr_index(l)) = -1 ELSE m = m + 1 dbcsr_index_nozeroes(m) = dbcsr_index(l) csr_index(dbcsr_index(l)) = m END IF END DO DEALLOCATE (dbcsr_index) dbcsr_index => dbcsr_index_nozeroes END IF IF (ANY(csr_nze .EQ. 0)) THEN csr_nze_local = m ELSE csr_nze_local = nze END IF CALL timestop(handle) END SUBROUTINE csr_get_dbcsr_mapping SUBROUTINE convert_csr_to_brd(brd_mat, csr_mat) !! Copies data from a CSR matrix to a block-row distributed DBCSR matrix. !! The DBCSR matrix must have a block structure consistent with the CSR matrix. TYPE(dbcsr_type), INTENT(INOUT) :: brd_mat !! block-row distributed DBCSR matrix TYPE(csr_type), INTENT(IN) :: csr_mat !! CSR matrix CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_csr_to_brd' INTEGER :: data_type, handle, ind, k, nze CALL timeset(routineN, handle) data_type = dbcsr_get_data_type(brd_mat) nze = dbcsr_get_nze(brd_mat) CALL dbcsr_data_release(brd_mat%data_area) CALL dbcsr_data_new(brd_mat%data_area, data_type, nze) SELECT CASE (data_type) CASE (dbcsr_type_real_4) brd_mat%data_area%d%r_sp(1:nze) = 0.0_sp CASE (dbcsr_type_real_8) brd_mat%data_area%d%r_dp(1:nze) = 0.0_dp CASE (dbcsr_type_complex_4) brd_mat%data_area%d%c_sp(1:nze) = 0.0_sp CASE (dbcsr_type_complex_8) brd_mat%data_area%d%c_dp(1:nze) = 0.0_dp END SELECT DO k = 1, csr_mat%nze_local ind = csr_mat%dbcsr_mapping%csr_to_brd_ind(k) SELECT CASE (data_type) CASE (dbcsr_type_real_4) brd_mat%data_area%d%r_sp(ind) = csr_mat%nzval_local%r_sp(k) CASE (dbcsr_type_real_8) brd_mat%data_area%d%r_dp(ind) = csr_mat%nzval_local%r_dp(k) CASE (dbcsr_type_complex_4) brd_mat%data_area%d%c_sp(ind) = csr_mat%nzval_local%c_sp(k) CASE (dbcsr_type_complex_8) brd_mat%data_area%d%c_dp(ind) = csr_mat%nzval_local%c_dp(k) END SELECT END DO CALL timestop(handle) END SUBROUTINE convert_csr_to_brd SUBROUTINE convert_brd_to_csr(brd_mat, csr_mat) !! Convert a block-row distributed DBCSR matrix to a CSR matrix !! The DBCSR matrix must have a block structure consistent with the CSR matrix. TYPE(dbcsr_type), INTENT(IN) :: brd_mat !! block-row distributed DBCSR matrix TYPE(csr_type), INTENT(INOUT) :: csr_mat !! CSR matrix CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_brd_to_csr' INTEGER :: blk, blkcol, blkrow, col_blk_offset, col_blk_size, csr_ind, data_type, dbcsr_ind, & el_sum, handle, ind_blk_data, k, local_row_ind, m, n, nblkrows_total, node_row_offset, & prev_blkrow, prev_row_blk_size, row_blk_offset, row_blk_size INTEGER, ALLOCATABLE, DIMENSION(:) :: nfullcol_blkrow INTEGER, DIMENSION(:), POINTER :: colind, csr_index, dbcsr_index, nzerow, & rowptr LOGICAL :: new_ind, tr TYPE(dbcsr_data_obj) :: block TYPE(dbcsr_iterator) :: iter CALL timeset(routineN, handle) local_row_ind = 0 dbcsr_ind = 0 node_row_offset = 0 NULLIFY (rowptr, colind, dbcsr_index, csr_index) dbcsr_index => csr_mat%dbcsr_mapping%csr_to_brd_ind csr_index => csr_mat%dbcsr_mapping%brd_to_csr_ind ! CSR indices are not recalculated if indices are already defined new_ind = .NOT. (csr_mat%has_indices) IF (.NOT. csr_mat%has_mapping) & DBCSR_ABORT("DBCSR mapping of CSR matrix must be defined") ! Calculate mapping between CSR matrix and DBCSR matrix if not yet defined !IF (.NOT. csr_mat%has_mapping ) THEN ! CALL csr_get_dbcsr_mapping (brd_mat, dbcsr_index, csr_index, nze) !ENDIF CALL dbcsr_get_info(brd_mat, nblkrows_total=nblkrows_total) ALLOCATE (nfullcol_blkrow(nblkrows_total)) ! iteration over blocks without touching data, ! in order to get number of non-zero full columns in each block row CALL dbcsr_iterator_start(iter, brd_mat, read_only=.TRUE.) blkrow = 0 nfullcol_blkrow = 0 ! number of non-zero full columns in each block row data_type = dbcsr_get_data_type(brd_mat) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, blkrow, blkcol, blk, col_size=col_blk_size, & row_offset=row_blk_offset) nfullcol_blkrow(blkrow) = nfullcol_blkrow(blkrow) + col_blk_size IF (blk .EQ. 1) THEN node_row_offset = row_blk_offset END IF END DO CALL dbcsr_iterator_stop(iter) ! Copy data from BRD matrix to CSR matrix and calculate CSR indices prev_blkrow = 0 prev_row_blk_size = 0 el_sum = 0 ! number of elements above current block row colind => csr_mat%colind_local rowptr => csr_mat%rowptr_local nzerow => csr_mat%nzerow_local CALL dbcsr_data_init(block) CALL dbcsr_data_new(block, data_type) CALL dbcsr_iterator_start(iter, brd_mat, read_only=.TRUE.) IF (new_ind) rowptr(:) = 0 ! initialize to 0 in order to check which rows are 0 at a later time DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, blkrow, blkcol, block, tr, & col_size=col_blk_size, row_size=row_blk_size, row_offset=row_blk_offset, & col_offset=col_blk_offset) IF (tr) & DBCSR_ABORT("DBCSR block data must not be transposed") IF (blkrow > prev_blkrow) THEN ! new block row local_row_ind = row_blk_offset - node_row_offset ! actually: local row index - 1 IF (prev_blkrow .GT. 0) THEN el_sum = el_sum + nfullcol_blkrow(prev_blkrow)*prev_row_blk_size END IF dbcsr_ind = el_sum END IF DO n = 1, col_blk_size !nr of columns DO m = 1, row_blk_size !nr of rows dbcsr_ind = dbcsr_ind + 1 csr_ind = csr_index(dbcsr_ind) ! get CSR index for current element IF (csr_ind .GT. 0) THEN ! is non-zero element if csr_ind > 0 IF (new_ind) THEN ! Calculate CSR column index colind(csr_ind) = col_blk_offset + n - 1 ! Calculate CSR row pointer ! (not accounting for zero elements inside non-zero blocks) IF (rowptr(local_row_ind + m) .LE. 0) rowptr(local_row_ind + m) = & rowptr(local_row_ind + m) + el_sum + 1 + nfullcol_blkrow(blkrow)*(m - 1) END IF ind_blk_data = (m + row_blk_size*(n - 1)) ! index of data inside DBCSR blocks SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) csr_mat%nzval_local%r_sp(csr_ind) = block%d%r_sp(ind_blk_data) CASE (dbcsr_type_real_8) csr_mat%nzval_local%r_dp(csr_ind) = block%d%r_dp(ind_blk_data) CASE (dbcsr_type_complex_4) csr_mat%nzval_local%c_sp(csr_ind) = block%d%c_sp(ind_blk_data) CASE (dbcsr_type_complex_8) csr_mat%nzval_local%c_dp(csr_ind) = block%d%c_dp(ind_blk_data) END SELECT ELSE ! is zero element if ind = -1 ! CSR row pointer has to be corrected if element is zero ! (subtract 1 from all subsequent row pointers) IF (new_ind) rowptr(local_row_ind + m + 1:) = rowptr(local_row_ind + m + 1:) - 1 END IF END DO END DO prev_blkrow = blkrow prev_row_blk_size = row_blk_size END DO IF (new_ind) THEN ! Repeat previous row pointer for row pointers to zero rows IF (csr_mat%nrows_local .GT. 0) rowptr(1) = 1 DO k = 1, csr_mat%nrows_local IF (rowptr(k) .LE. 0) rowptr(k) = rowptr(k - 1) END DO rowptr(csr_mat%nrows_local + 1) = csr_mat%nze_local + 1 END IF CALL csr_create_nzerow(csr_mat, nzerow) CALL dbcsr_iterator_stop(iter) CALL dbcsr_data_clear_pointer(block) CALL dbcsr_data_release(block) IF (new_ind) csr_mat%has_indices = .TRUE. CALL timestop(handle) END SUBROUTINE convert_brd_to_csr SUBROUTINE csr_create_from_dbcsr(dbcsr_mat, csr_mat, dist_format, csr_sparsity, numnodes) !! create CSR matrix including dbcsr_mapping from arbitrary DBCSR matrix !! in order to prepare conversion. TYPE(dbcsr_type), INTENT(IN) :: dbcsr_mat TYPE(csr_type), INTENT(OUT) :: csr_mat INTEGER, INTENT(IN) :: dist_format !! how to distribute CSR rows over processes: csr_dbcsr_blkrow_dist: the number of rows per process is adapted to the row !! block sizes in the DBCSR format such that blocks are not split over different processes. csr_eqrow_ceil_dist: each !! process holds ceiling(N/P) CSR rows. csr_eqrow_floor_dist: each process holds floor(N/P) CSR rows. TYPE(dbcsr_type), INTENT(IN), OPTIONAL :: csr_sparsity !! DBCSR matrix containing 0 and 1, representing CSR sparsity pattern 1: non-zero element 0: zero element (not present in !! CSR format) Note: matrix must be of data_type dbcsr_type_real_4 or dbcsr_type_real_8 (integer types not supported) INTEGER, INTENT(IN), OPTIONAL :: numnodes !! number of nodes to use for distributing CSR matrix (optional, default is number of nodes used for DBCSR matrix) CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_create_from_dbcsr' INTEGER :: dbcsr_numnodes, handle, nblkcols_total, & nblkrows_total, nblks_local, num_p LOGICAL :: equal_dist, floor_dist TYPE(dbcsr_type) :: brd_mat, csr_sparsity_brd, & csr_sparsity_nosym, dbcsr_mat_nosym CALL timeset(routineN, handle) IF (.NOT. dbcsr_valid_index(dbcsr_mat)) & DBCSR_ABORT("Invalid DBCSR matrix") SELECT CASE (dist_format) CASE (csr_dbcsr_blkrow_dist) equal_dist = .FALSE. floor_dist = .FALSE. CASE (csr_eqrow_ceil_dist) equal_dist = .TRUE. floor_dist = .FALSE. CASE (csr_eqrow_floor_dist) equal_dist = .TRUE. floor_dist = .TRUE. END SELECT ! Conversion does not support matrices in symmetric format, therefore desymmetrize IF (dbcsr_has_symmetry(dbcsr_mat)) THEN CALL dbcsr_desymmetrize_deep(dbcsr_mat, dbcsr_mat_nosym, untransposed_data=.TRUE.) ELSE CALL dbcsr_copy(dbcsr_mat_nosym, dbcsr_mat) END IF IF (PRESENT(csr_sparsity)) THEN IF (dbcsr_has_symmetry(csr_sparsity)) THEN CALL dbcsr_desymmetrize_deep(csr_sparsity, csr_sparsity_nosym, & untransposed_data=.TRUE.) ELSE CALL dbcsr_copy(csr_sparsity_nosym, csr_sparsity) END IF ELSE CALL dbcsr_create(csr_sparsity_nosym, & template=dbcsr_mat_nosym, & name="CSR sparsity matrix", & data_type=dbcsr_type_real_8) CALL dbcsr_copy(csr_sparsity_nosym, dbcsr_mat_nosym) CALL dbcsr_set(csr_sparsity_nosym, 1.0_dp) END IF IF (.NOT. dbcsr_has_same_block_structure(dbcsr_mat_nosym, csr_sparsity_nosym)) & DBCSR_ABORT("csr_sparsity and dbcsr_mat have different sparsity pattern") dbcsr_numnodes = dbcsr_mp_numnodes(dbcsr_distribution_mp(dbcsr_distribution(dbcsr_mat))) IF (PRESENT(numnodes)) THEN IF (numnodes .GT. dbcsr_numnodes) & CALL dbcsr_abort(__LOCATION__, "Number of nodes used for CSR matrix "// & "must not exceed total number of nodes") num_p = numnodes ELSE num_p = dbcsr_numnodes END IF CALL dbcsr_create_brd(dbcsr_mat_nosym, brd_mat, equal_dist, floor_dist, & num_p) CALL dbcsr_create_brd(csr_sparsity_nosym, csr_sparsity_brd, equal_dist, floor_dist, & num_p) ! Create CSR matrix from BRD matrix CALL csr_create_from_brd(brd_mat, csr_mat, csr_sparsity_brd) ! Store DBCSR block data inside CSR matrix ! (otherwise, this data is lost when converting from DBCSR to CSR) nblks_local = dbcsr_get_num_blocks(dbcsr_mat_nosym) nblkrows_total = dbcsr_nblkrows_total(dbcsr_mat_nosym) nblkcols_total = dbcsr_nblkcols_total(dbcsr_mat_nosym) csr_mat%dbcsr_mapping%dbcsr_nblkcols_total = nblkcols_total csr_mat%dbcsr_mapping%dbcsr_nblkrows_total = nblkrows_total csr_mat%dbcsr_mapping%dbcsr_nblks_local = nblks_local ALLOCATE (csr_mat%dbcsr_mapping%dbcsr_row_p(nblkrows_total + 1)) csr_mat%dbcsr_mapping%dbcsr_row_p = dbcsr_mat_nosym%row_p ALLOCATE (csr_mat%dbcsr_mapping%dbcsr_col_i(nblks_local)) csr_mat%dbcsr_mapping%dbcsr_col_i = dbcsr_mat_nosym%col_i ALLOCATE (csr_mat%dbcsr_mapping%dbcsr_row_blk_size(nblkrows_total)) ALLOCATE (csr_mat%dbcsr_mapping%dbcsr_col_blk_size(nblkcols_total)) csr_mat%dbcsr_mapping%dbcsr_row_blk_size = dbcsr_row_block_sizes(dbcsr_mat_nosym) csr_mat%dbcsr_mapping%dbcsr_col_blk_size = dbcsr_col_block_sizes(dbcsr_mat_nosym) csr_mat%dbcsr_mapping%has_dbcsr_block_data = .TRUE. CALL dbcsr_release(dbcsr_mat_nosym) CALL dbcsr_release(csr_sparsity_nosym) CALL dbcsr_release(csr_sparsity_brd) CALL timestop(handle) END SUBROUTINE csr_create_from_dbcsr FUNCTION dbcsr_has_same_block_structure(matrix_a, matrix_b) RESULT(is_equal) !! Helper function to assert that two DBCSR matrices have the same block !! structure and same sparsity pattern TYPE(dbcsr_type), INTENT(IN) :: matrix_a, matrix_b LOGICAL :: is_equal !! whether matrix_a and matrix_b have the same block structure is_equal = .TRUE. IF (dbcsr_nblkcols_total(matrix_a) .NE. dbcsr_nblkcols_total(matrix_b)) is_equal = .FALSE. IF (dbcsr_nblkrows_total(matrix_a) .NE. dbcsr_nblkrows_total(matrix_b)) is_equal = .FALSE. IF ((matrix_a%nblks) .NE. (matrix_b%nblks)) is_equal = .FALSE. IF (ANY(matrix_a%row_p .NE. matrix_b%row_p)) is_equal = .FALSE. IF (ANY(matrix_a%col_i .NE. matrix_b%col_i)) is_equal = .FALSE. IF (ANY(dbcsr_row_block_sizes(matrix_a) .NE. & dbcsr_row_block_sizes(matrix_b))) is_equal = .FALSE. IF (ANY(dbcsr_row_block_sizes(matrix_a) .NE. & dbcsr_row_block_sizes(matrix_b))) is_equal = .FALSE. END FUNCTION dbcsr_has_same_block_structure SUBROUTINE csr_assert_consistency_with_dbcsr(csr_mat, dbcsr_mat) !! Helper function to assert that a given CSR matrix and a given DBCSR !! matrix are consistent before doing the conversion TYPE(csr_type), INTENT(IN) :: csr_mat TYPE(dbcsr_type), INTENT(IN) :: dbcsr_mat CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_assert_consistency_with_dbcsr' INTEGER :: handle TYPE(csr_mapping_data) :: map CALL timeset(routineN, handle) map = csr_mat%dbcsr_mapping IF (map%has_dbcsr_block_data) THEN IF (map%dbcsr_nblkcols_total .NE. dbcsr_nblkcols_total(dbcsr_mat)) & CALL dbcsr_abort(__LOCATION__, & "field nblkcols_total of DBCSR matrix not consistent with CSR matrix") IF (map%dbcsr_nblkrows_total .NE. dbcsr_nblkrows_total(dbcsr_mat)) & CALL dbcsr_abort(__LOCATION__, & "field nblkrows_total of DBCSR matrix not consistent with CSR matrix") IF (map%dbcsr_nblks_local .NE. dbcsr_mat%nblks) & CALL dbcsr_abort(__LOCATION__, & "field nblks of DBCSR matrix not consistent with CSR matrix") IF (ANY(map%dbcsr_row_p .NE. dbcsr_mat%row_p)) & CALL dbcsr_abort(__LOCATION__, & "field row_p of DBCSR matrix not consistent with CSR matrix") IF (ANY(map%dbcsr_col_i .NE. dbcsr_mat%col_i)) & CALL dbcsr_abort(__LOCATION__, & "field dbcsr_col_i of DBCSR matrix not consistent with CSR matrix") IF (ANY(map%dbcsr_row_blk_size .NE. dbcsr_row_block_sizes(dbcsr_mat))) & CALL dbcsr_abort(__LOCATION__, & "field row_blk_size of DBCSR matrix not consistent with CSR matrix") IF (ANY(map%dbcsr_col_blk_size .NE. dbcsr_col_block_sizes(dbcsr_mat))) & CALL dbcsr_abort(__LOCATION__, & "field col_blk_size of DBCSR matrix not consistent with CSR matrix") ELSE CALL dbcsr_warn(__LOCATION__, "Can not assert consistency of the matrices "// & "as no block data stored in CSR matrix.") END IF CALL timestop(handle) END SUBROUTINE csr_assert_consistency_with_dbcsr SUBROUTINE convert_dbcsr_to_csr(dbcsr_mat, csr_mat) !! Convert a DBCSR matrix to a CSR matrix. TYPE(dbcsr_type), INTENT(IN) :: dbcsr_mat !! DBCSR matrix to convert TYPE(csr_type), INTENT(INOUT) :: csr_mat !! correctly allocated CSR matrix CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_dbcsr_to_csr' INTEGER :: handle TYPE(dbcsr_type) :: dbcsr_mat_nosym CALL timeset(routineN, handle) IF (.NOT. dbcsr_valid_index(dbcsr_mat)) & DBCSR_ABORT("Invalid DBCSR matrix") IF (dbcsr_get_data_type(dbcsr_mat) /= csr_mat%nzval_local%data_type) & DBCSR_ABORT("DBCSR and CSR matrix must have same type") IF (.NOT. csr_mat%has_mapping) & DBCSR_ABORT("CSR_mat must contain mapping to DBCSR format") IF (dbcsr_has_symmetry(dbcsr_mat)) THEN CALL dbcsr_desymmetrize_deep(dbcsr_mat, dbcsr_mat_nosym, untransposed_data=.TRUE.) ELSE dbcsr_mat_nosym = dbcsr_mat END IF CALL csr_assert_consistency_with_dbcsr(csr_mat, dbcsr_mat_nosym) ! 1) DBCSR -> BRD CALL dbcsr_complete_redistribute(dbcsr_mat_nosym, csr_mat%dbcsr_mapping%brd_mat) ! 2) BRD -> CSR CALL convert_brd_to_csr(csr_mat%dbcsr_mapping%brd_mat, csr_mat) IF (dbcsr_has_symmetry(dbcsr_mat)) CALL dbcsr_release(dbcsr_mat_nosym) CALL timestop(handle) END SUBROUTINE convert_dbcsr_to_csr SUBROUTINE convert_csr_to_dbcsr(dbcsr_mat, csr_mat) !! convert a CSR matrix to a DBCSR matrix TYPE(dbcsr_type), INTENT(INOUT) :: dbcsr_mat !! correctly allocated DBCSR matrix TYPE(csr_type), INTENT(INOUT) :: csr_mat !! CSR matrix to convert CHARACTER(LEN=*), PARAMETER :: routineN = 'convert_csr_to_dbcsr' INTEGER :: handle TYPE(dbcsr_type) :: dbcsr_mat_nosym CALL timeset(routineN, handle) IF (.NOT. dbcsr_valid_index(dbcsr_mat)) & DBCSR_ABORT("Invalid DBCSR matrix") IF (dbcsr_get_data_type(dbcsr_mat) /= csr_mat%nzval_local%data_type) & DBCSR_ABORT("DBCSR and CSR matrix must have same type") IF (.NOT. csr_mat%has_mapping) & DBCSR_ABORT("CSR_mat must contain mapping to DBCSR format") ! Desymmetrize to assert that DBCSR matrix has sparsity pattern consistent with CSR matrix IF (dbcsr_has_symmetry(dbcsr_mat)) THEN CALL dbcsr_desymmetrize_deep(dbcsr_mat, dbcsr_mat_nosym, untransposed_data=.TRUE.) ELSE dbcsr_mat_nosym = dbcsr_mat END IF CALL csr_assert_consistency_with_dbcsr(csr_mat, dbcsr_mat_nosym) IF (dbcsr_has_symmetry(dbcsr_mat)) CALL dbcsr_release(dbcsr_mat_nosym) ! 1) CSR -> BRD CALL convert_csr_to_brd(csr_mat%dbcsr_mapping%brd_mat, csr_mat) ! 2) BRD -> DBCSR CALL dbcsr_complete_redistribute(csr_mat%dbcsr_mapping%brd_mat, dbcsr_mat) CALL timestop(handle) END SUBROUTINE convert_csr_to_dbcsr SUBROUTINE dbcsr_to_csr_filter(dbcsr_mat, csr_sparsity, eps) !! Apply filtering threshold eps to DBCSR blocks in order to improve !! CSR sparsity (currently only used for testing purposes) TYPE(dbcsr_type), INTENT(IN) :: dbcsr_mat TYPE(dbcsr_type), INTENT(OUT) :: csr_sparsity REAL(kind=real_8), INTENT(IN) :: eps INTEGER :: blkcol, blkrow, col_blk_size, data_type, & row_blk_size LOGICAL :: tr REAL(kind=real_8), ALLOCATABLE, DIMENSION(:) :: block_abs, csr_sparsity_blk TYPE(dbcsr_data_obj) :: block TYPE(dbcsr_iterator) :: iter !REAL(kind=real_8), DIMENSION(:), POINTER :: block CALL dbcsr_create(csr_sparsity, & template=dbcsr_mat, & name="CSR sparsity", & data_type=dbcsr_type_real_8) CALL dbcsr_copy(csr_sparsity, dbcsr_mat) CALL dbcsr_set(csr_sparsity, 1.0_dp) IF (eps .GT. 0.0_dp) THEN data_type = dbcsr_get_data_type(dbcsr_mat) CALL dbcsr_data_init(block) CALL dbcsr_data_new(block, data_type) CALL dbcsr_iterator_start(iter, dbcsr_mat, read_only=.TRUE.) DO WHILE (dbcsr_iterator_blocks_left(iter)) CALL dbcsr_iterator_next_block(iter, blkrow, blkcol, block, transposed=tr, & row_size=row_blk_size, col_size=col_blk_size) ALLOCATE (block_abs(row_blk_size*col_blk_size)) ALLOCATE (csr_sparsity_blk(row_blk_size*col_blk_size)) SELECT CASE (data_type) CASE (dbcsr_type_real_4) block_abs(:) = REAL(ABS(block%d%r_sp(:)), KIND=real_8) CASE (dbcsr_type_real_8) block_abs(:) = REAL(ABS(block%d%r_dp(:)), KIND=real_8) CASE (dbcsr_type_complex_4) block_abs(:) = REAL(ABS(block%d%c_sp(:)), KIND=real_8) CASE (dbcsr_type_complex_8) block_abs(:) = REAL(ABS(block%d%c_dp(:)), KIND=real_8) END SELECT csr_sparsity_blk = 1.0_dp WHERE (block_abs .LT. eps) csr_sparsity_blk = 0.0_dp CALL dbcsr_put_block(csr_sparsity, blkrow, blkcol, csr_sparsity_blk, transposed=tr) DEALLOCATE (csr_sparsity_blk, block_abs) END DO CALL dbcsr_iterator_stop(iter) CALL dbcsr_data_clear_pointer(block) CALL dbcsr_data_release(block) END IF END SUBROUTINE dbcsr_to_csr_filter SUBROUTINE csr_write(csr_mat, unit_nr, upper_triangle, threshold, binary) !! Write a CSR matrix to file TYPE(csr_type), INTENT(IN) :: csr_mat INTEGER, INTENT(IN) :: unit_nr !! unit number to which output is written LOGICAL, INTENT(IN), OPTIONAL :: upper_triangle !! If true (default: false), write only upper triangular part of matrix REAL(KIND=real_8), INTENT(IN), OPTIONAL :: threshold !! threshold on the absolute value of the elements to be printed LOGICAL, INTENT(IN), OPTIONAL :: binary CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_write' CHARACTER(LEN=default_string_length) :: data_format COMPLEX(KIND=real_4), ALLOCATABLE, DIMENSION(:) :: nzval_to_master_c_sp COMPLEX(KIND=real_8), ALLOCATABLE, DIMENSION(:) :: nzval_to_master_c_dp INTEGER :: handle, i, ii, k, l, m, mynode, & numnodes, rowind, tag1, tag2, tag3 INTEGER, ALLOCATABLE, DIMENSION(:) :: colind_to_master, nzerow_to_master, & sizes_numrowlocal, sizes_nzelocal LOGICAL :: bin, ut REAL(KIND=real_4), ALLOCATABLE, DIMENSION(:) :: nzval_to_master_r_sp REAL(KIND=real_8) :: thld REAL(KIND=real_8), ALLOCATABLE, DIMENSION(:) :: nzval_to_master_r_dp CALL timeset(routineN, handle) IF (PRESENT(upper_triangle)) THEN ut = upper_triangle ELSE ut = .FALSE. END IF IF (PRESENT(threshold)) THEN thld = threshold ELSE thld = 0.0_dp END IF IF (PRESENT(binary)) THEN bin = binary ELSE bin = .FALSE. END IF IF (.NOT. csr_mat%valid) & DBCSR_ABORT("can not write invalid CSR matrix") tag1 = 0 tag2 = 1 tag3 = 2 CALL mp_environ(numnodes, mynode, csr_mat%mp_group) ! gather sizes (number of local non-zero elements and number of local rows) ALLOCATE (sizes_nzelocal(numnodes)) ALLOCATE (sizes_numrowlocal(numnodes)) CALL mp_gather(csr_mat%nze_local, sizes_nzelocal, 0, csr_mat%mp_group) CALL mp_gather(csr_mat%nrows_local, sizes_numrowlocal, 0, csr_mat%mp_group) ! for each node, send matrix data to node 0 (master) and write data DO i = 0, numnodes - 1 ii = i IF (mynode .EQ. 0) THEN ! allocations for receiving data from node i ALLOCATE (colind_to_master(sizes_nzelocal(ii + 1))) ALLOCATE (nzerow_to_master(sizes_numrowlocal(ii + 1))) SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) data_format = "(2(I8),E23.6E2)" ALLOCATE (nzval_to_master_r_sp(sizes_nzelocal(ii + 1))) CASE (dbcsr_type_real_8) data_format = "(2(I8),E23.14E3)" ALLOCATE (nzval_to_master_r_dp(sizes_nzelocal(ii + 1))) CASE (dbcsr_type_complex_4) data_format = "(2(I8),2(E23.6E2))" ALLOCATE (nzval_to_master_c_sp(sizes_nzelocal(ii + 1))) CASE (dbcsr_type_complex_8) data_format = "(2(I8),2(E23.14E3))" ALLOCATE (nzval_to_master_c_dp(sizes_nzelocal(ii + 1))) END SELECT END IF IF (mynode .EQ. 0) THEN ! receive at node 0 IF (ii .EQ. 0) THEN ! data from node 0, no need for mpi routines colind_to_master(:) = csr_mat%colind_local(:) nzerow_to_master(:) = csr_mat%nzerow_local(:) SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) nzval_to_master_r_sp(:) = csr_mat%nzval_local%r_sp(:) CASE (dbcsr_type_real_8) nzval_to_master_r_dp(:) = csr_mat%nzval_local%r_dp(:) CASE (dbcsr_type_complex_4) nzval_to_master_c_sp(:) = csr_mat%nzval_local%c_sp(:) CASE (dbcsr_type_complex_8) nzval_to_master_c_dp(:) = csr_mat%nzval_local%c_dp(:) END SELECT ELSE ! receive data from nodes with rank > 0 CALL mp_recv(colind_to_master, ii, tag1, csr_mat%mp_group) CALL mp_recv(nzerow_to_master, ii, tag2, csr_mat%mp_group) SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) CALL mp_recv(nzval_to_master_r_sp, ii, tag3, csr_mat%mp_group) CASE (dbcsr_type_real_8) CALL mp_recv(nzval_to_master_r_dp, ii, tag3, csr_mat%mp_group) CASE (dbcsr_type_complex_4) CALL mp_recv(nzval_to_master_c_sp, ii, tag3, csr_mat%mp_group) CASE (dbcsr_type_complex_8) CALL mp_recv(nzval_to_master_c_dp, ii, tag3, csr_mat%mp_group) END SELECT END IF END IF IF ((mynode .EQ. ii) .AND. (ii .NE. 0)) THEN ! send from nodes with rank > 0 CALL mp_send(csr_mat%colind_local, 0, tag1, csr_mat%mp_group) CALL mp_send(csr_mat%nzerow_local, 0, tag2, csr_mat%mp_group) SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) CALL mp_send(csr_mat%nzval_local%r_sp, 0, tag3, csr_mat%mp_group) CASE (dbcsr_type_real_8) CALL mp_send(csr_mat%nzval_local%r_dp, 0, tag3, csr_mat%mp_group) CASE (dbcsr_type_complex_4) CALL mp_send(csr_mat%nzval_local%c_sp, 0, tag3, csr_mat%mp_group) CASE (dbcsr_type_complex_8) CALL mp_send(csr_mat%nzval_local%c_dp, 0, tag3, csr_mat%mp_group) END SELECT END IF IF (mynode .EQ. 0) THEN ! write data received at node 0 !WRITE(unit_nr,"(A27)") "#row ind, col ind, value" m = 0 DO k = 1, sizes_numrowlocal(ii + 1) rowind = k + SUM(sizes_numrowlocal(1:ii)) ! row index: local to global DO l = 1, nzerow_to_master(k) m = m + 1 IF ((.NOT. ut) .OR. (rowind .LE. colind_to_master(m))) THEN SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) IF (ABS(nzval_to_master_r_sp(m)) .GE. thld) THEN IF (bin) THEN WRITE (unit_nr) rowind, colind_to_master(m), nzval_to_master_r_sp(m) ELSE WRITE (unit_nr, data_format) rowind, colind_to_master(m), & nzval_to_master_r_sp(m) END IF END IF CASE (dbcsr_type_real_8) IF (ABS(nzval_to_master_r_dp(m)) .GE. thld) THEN IF (bin) THEN WRITE (unit_nr) rowind, colind_to_master(m), nzval_to_master_r_dp(m) ELSE WRITE (unit_nr, data_format) rowind, colind_to_master(m), & nzval_to_master_r_dp(m) END IF END IF CASE (dbcsr_type_complex_4) IF (ABS(nzval_to_master_c_sp(m)) .GE. thld) THEN IF (bin) THEN WRITE (unit_nr) rowind, colind_to_master(m), nzval_to_master_c_sp(m) ELSE WRITE (unit_nr, data_format) rowind, colind_to_master(m), & nzval_to_master_c_sp(m) END IF END IF CASE (dbcsr_type_complex_8) IF (ABS(nzval_to_master_c_dp(m)) .GE. thld) THEN IF (bin) THEN WRITE (unit_nr) rowind, colind_to_master(m), nzval_to_master_c_dp(m) ELSE WRITE (unit_nr, data_format) rowind, colind_to_master(m), & nzval_to_master_c_dp(m) END IF END IF END SELECT END IF END DO END DO DEALLOCATE (colind_to_master) DEALLOCATE (nzerow_to_master) SELECT CASE (csr_mat%nzval_local%data_type) CASE (dbcsr_type_real_4) DEALLOCATE (nzval_to_master_r_sp) CASE (dbcsr_type_real_8) DEALLOCATE (nzval_to_master_r_dp) CASE (dbcsr_type_complex_4) DEALLOCATE (nzval_to_master_c_sp) CASE (dbcsr_type_complex_8) DEALLOCATE (nzval_to_master_c_dp) END SELECT END IF END DO CALL timestop(handle) END SUBROUTINE csr_write SUBROUTINE csr_print_sparsity(csr_mat, unit_nr) !! Print CSR sparsity TYPE(csr_type), INTENT(IN) :: csr_mat INTEGER, INTENT(IN) :: unit_nr CHARACTER(LEN=*), PARAMETER :: routineN = 'csr_print_sparsity' INTEGER :: handle, mynode, numnodes INTEGER(KIND=int_8) :: dbcsr_nze_total REAL(KIND=real_8) :: dbcsr_nze_percentage, nze_percentage CALL timeset(routineN, handle) IF (.NOT. csr_mat%valid) & DBCSR_ABORT("CSR matrix must be created first") nze_percentage = 100.0_dp*(REAL(csr_mat%nze_total, KIND=real_8) & /REAL(csr_mat%nrows_total, KIND=real_8)) & /REAL(csr_mat%ncols_total, KIND=real_8) IF (csr_mat%has_mapping) THEN dbcsr_nze_total = dbcsr_get_nze(csr_mat%dbcsr_mapping%brd_mat) CALL mp_sum(dbcsr_nze_total, csr_mat%mp_group) dbcsr_nze_percentage = 100.0_dp*(REAL(dbcsr_nze_total, KIND=real_8) & /REAL(csr_mat%nrows_total, KIND=real_8)) & /REAL(csr_mat%ncols_total, KIND=real_8) END IF CALL mp_environ(numnodes, mynode, csr_mat%mp_group) IF (mynode .EQ. 0) THEN WRITE (unit_nr, "(T15,A,T68,I13)") "Number of CSR non-zero elements:", csr_mat%nze_total WRITE (unit_nr, "(T15,A,T75,F6.2)") "Percentage CSR non-zero elements:", nze_percentage !IF(csr_mat%has_mapping) THEN ! WRITE(unit_nr,"(T15,A,T75,F6.2/)") "Percentage DBCSR non-zero elements:", dbcsr_nze_percentage !ENDIF END IF CALL timestop(handle) END SUBROUTINE csr_print_sparsity SUBROUTINE dbcsr_create_brd(dbcsr_mat, brd_mat, equal_dist, floor_dist, numnodes) !! Converts a DBCSR matrix to a block row distributed matrix. TYPE(dbcsr_type), INTENT(IN) :: dbcsr_mat !! DBCSR matrix to be converted TYPE(dbcsr_type), INTENT(OUT) :: brd_mat !! converted matrix LOGICAL, INTENT(IN) :: equal_dist, floor_dist !! see documentation of csr_create_from_dbcsr !! see documentation of csr_create_from_dbcsr INTEGER, INTENT(IN) :: numnodes !! number of nodes to use for block row distribution CHARACTER(LEN=*), PARAMETER :: routineN = 'dbcsr_create_brd' CHARACTER :: matrix_type CHARACTER(LEN=default_string_length) :: matrix_name INTEGER :: cs, data_type, end_ind, handle, i, k, l, m, mynode, nblkcols_total, & nblkrows_total, nfullrows_local, nfullrows_total, node_size, numnodes_total, row_index, & split_row, start_ind INTEGER, ALLOCATABLE, DIMENSION(:) :: rdist_tmp, row_blk_size_new_tmp INTEGER, ALLOCATABLE, DIMENSION(:, :) :: pgrid INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: cdist, col_blk_size, rdist, & row_blk_size, row_blk_size_new REAL(KIND=real_8) :: chunk_size TYPE(dbcsr_distribution_obj) :: dist_current, dist_new TYPE(dbcsr_mp_obj) :: mp_obj_current, mp_obj_new TYPE(mp_comm_type) :: mp_group CALL timeset(routineN, handle) NULLIFY (row_blk_size, rdist, row_blk_size_new) CALL dbcsr_get_info(dbcsr_mat, & nblkrows_total=nblkrows_total, & nblkcols_total=nblkcols_total, & nfullrows_total=nfullrows_total, & row_blk_size=row_blk_size, & col_blk_size=col_blk_size, & matrix_type=matrix_type, & data_type=data_type) matrix_name = dbcsr_name(dbcsr_mat) ALLOCATE (cdist(nblkcols_total)) cdist = 0 dist_current = dbcsr_distribution(dbcsr_mat) mp_obj_current = dbcsr_distribution_mp(dist_current) mp_group = dbcsr_mp_group(mp_obj_current) mynode = dbcsr_mp_mynode(mp_obj_current) numnodes_total = dbcsr_mp_numnodes(mp_obj_current) ALLOCATE (pgrid(numnodes_total, 1)) IF (equal_dist) THEN ! Equally distribute rows over processors -> cut blocks ! Calculate the number of rows a processor can hold IF (floor_dist) THEN nfullrows_local = FLOOR(REAL(nfullrows_total, KIND=dp)/numnodes) ELSE nfullrows_local = CEILING(REAL(nfullrows_total, KIND=dp)/numnodes) END IF ! allocate maximum amount of memory possibly needed ALLOCATE (rdist_tmp(nblkrows_total + numnodes - 1)) ! row distribution ALLOCATE (row_blk_size_new_tmp(nblkrows_total + numnodes - 1)) ! new sizes of block rows k = 0 ! counter for block rows m = 0 ! node counter node_size = nfullrows_local ! space available on current node in number of rows IF (node_size .GT. 0) THEN DO l = 1, nblkrows_total split_row = row_blk_size(l) ! size of current block row (number of rows) DO WHILE (split_row .GE. node_size) ! cut block row and send it to two nodes k = k + 1 m = m + 1 row_blk_size_new_tmp(k) = node_size ! size of first part of block row rdist_tmp(k) = m - 1 ! send first part to node m split_row = split_row - node_size ! size of remaining part of block rows node_size = nfullrows_local ! space available on next node IF (floor_dist .AND. (m .EQ. numnodes - 1)) THEN ! send all remaining rows to last node node_size = nfullrows_total - (numnodes - 1)*node_size END IF END DO IF (split_row .GT. 0) THEN ! enough space left on next node for remaining rows k = k + 1 row_blk_size_new_tmp(k) = split_row ! size of remaining part of block row rdist_tmp(k) = m ! send to next node node_size = node_size - split_row ! remaining space on next node END IF END DO ELSE ! send everything to last node if node_size = 0 rdist_tmp(1:nblkrows_total) = numnodes - 1 row_blk_size_new_tmp(1:nblkrows_total) = row_blk_size ! row blocks unchanged k = nblkrows_total END IF ! Copy data to correctly allocated variables ALLOCATE (row_blk_size_new(k)) row_blk_size_new = row_blk_size_new_tmp(1:k) ALLOCATE (rdist(k)) rdist = rdist_tmp(1:k) ELSE ! Leave block rows intact (do not cut) ALLOCATE (rdist(nblkrows_total)) rdist = 0 IF (numnodes .GT. nblkrows_total) THEN rdist = (/(i, i=0, nblkrows_total - 1)/) ELSE chunk_size = REAL(nblkrows_total, KIND=dp)/numnodes row_index = 0 start_ind = 1 DO i = 0, numnodes - 1 cs = NINT(i*chunk_size) - NINT((i - 1)*chunk_size) end_ind = MIN(start_ind - 1 + cs, nblkrows_total) rdist(start_ind:end_ind) = row_index start_ind = end_ind + 1 row_index = row_index + 1 END DO END IF row_blk_size_new => row_blk_size END IF pgrid(:, :) = RESHAPE((/(i, i=0, numnodes_total - 1)/), (/numnodes_total, 1/)) CALL dbcsr_mp_new(mp_obj_new, mp_group, pgrid, mynode, numnodes=numnodes_total) CALL dbcsr_distribution_new(dist_new, mp_obj_new, rdist, cdist, reuse_arrays=.TRUE.) CALL dbcsr_create(brd_mat, TRIM(matrix_name)//" row-block distributed", & dist_new, matrix_type, row_blk_size_new, col_blk_size, data_type=data_type) CALL dbcsr_complete_redistribute(dbcsr_mat, brd_mat) DEALLOCATE (pgrid) IF (equal_dist) DEALLOCATE (row_blk_size_new) CALL dbcsr_distribution_release(dist_new) CALL dbcsr_mp_release(mp_obj_new) CALL timestop(handle) END SUBROUTINE dbcsr_create_brd END MODULE dbcsr_csr_conversions