copy a matrix, retaining current sparsity
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(dbcsr_type), | intent(inout) | :: | matrix_b |
target DBCSR matrix |
||
type(dbcsr_type), | intent(in) | :: | matrix_a |
source DBCSR matrix |
SUBROUTINE dbcsr_copy_into_existing_sym(matrix_b, matrix_a)
!! copy a matrix, retaining current sparsity
TYPE(dbcsr_type), INTENT(INOUT) :: matrix_b
!! target DBCSR matrix
TYPE(dbcsr_type), INTENT(IN) :: matrix_a
!! source DBCSR matrix
CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_copy_into_existing_sym'
INTEGER :: col_size, data_type, dst_col, dst_row, &
handle, row_size, src_col, src_cs, &
src_row, src_rs
LOGICAL :: dst_tr, found, neg_imag, neg_real, src_tr
TYPE(dbcsr_data_obj) :: dst_data, src_data
TYPE(dbcsr_iterator) :: dst_iter
! ---------------------------------------------------------------------------
CALL timeset(routineN, handle)
IF (dbcsr_get_data_type(matrix_b) .NE. dbcsr_get_data_type(matrix_a)) &
DBCSR_ABORT("Matrices have different data types.")
data_type = dbcsr_get_data_type(matrix_b)
IF (.NOT. dbcsr_has_symmetry(matrix_b) .OR. dbcsr_has_symmetry(matrix_a)) &
DBCSR_ABORT("Must copy from non-symmetric to symmetric matrix.")
neg_real = matrix_b%negate_real
neg_imag = matrix_b%negate_imaginary
CALL dbcsr_data_init(src_data)
CALL dbcsr_data_init(dst_data)
CALL dbcsr_data_new(src_data, data_type)
CALL dbcsr_data_new(dst_data, data_type)
CALL dbcsr_iterator_start(dst_iter, matrix_b)
! Iterate through the blocks of the destination matrix. For each
! one, try to find an appropriate source matrix block and copy it
! into the destination matrix.
DO WHILE (dbcsr_iterator_blocks_left(dst_iter))
CALL dbcsr_iterator_next_block(dst_iter, dst_row, dst_col, dst_data, &
dst_tr, row_size=row_size, col_size=col_size)
src_row = dst_row
src_col = dst_col
IF (checker_tr(dst_row, dst_col)) &
CALL swap(src_row, src_col)
CALL dbcsr_get_block_p(matrix_a, src_row, src_col, src_data, src_tr, &
found=found, row_size=src_rs, col_size=src_cs)
IF (.NOT. found) THEN
CALL dbcsr_data_clear(dst_data)
ELSE
IF (checker_tr(dst_row, dst_col)) THEN
src_tr = .NOT. src_tr
CALL swap(src_rs, src_cs)
END IF
CALL dbcsr_block_partial_copy(dst=dst_data, dst_tr=dst_tr, &
dst_rs=row_size, dst_cs=col_size, &
dst_r_lb=1, dst_c_lb=1, &
src=src_data, src_tr=src_tr, &
src_rs=src_rs, src_cs=src_cs, &
src_r_lb=1, src_c_lb=1, &
nrow=row_size, ncol=col_size)
IF (neg_real .AND. checker_tr(dst_row, dst_col)) THEN
CALL dbcsr_block_real_neg(dst_data, row_size, col_size)
END IF
IF (neg_imag .AND. checker_tr(dst_row, dst_col)) THEN
CALL dbcsr_block_conjg(dst_data, row_size, col_size)
END IF
END IF
END DO
CALL dbcsr_iterator_stop(dst_iter)
CALL dbcsr_data_clear_pointer(src_data)
CALL dbcsr_data_clear_pointer(dst_data)
CALL dbcsr_data_release(src_data)
CALL dbcsr_data_release(dst_data)
CALL timestop(handle)
END SUBROUTINE dbcsr_copy_into_existing_sym