Make the reduction of the 3D layers in the local csr object
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(dbcsr_mm_csr_type), | intent(inout) | :: | this | |||
integer, | intent(in), | DIMENSION(:), TARGET | :: | meta_buffer | ||
type(dbcsr_data_obj), | intent(in) | :: | data_buffer | |||
integer(kind=int_8), | intent(inout) | :: | flop | |||
integer, | intent(in), | DIMENSION(:) | :: | m_sizes | ||
integer, | intent(in), | DIMENSION(:) | :: | n_sizes | ||
integer, | intent(in), | DIMENSION(:) | :: | g2l_map_rows | ||
integer, | intent(in), | DIMENSION(:) | :: | g2l_map_cols | ||
integer, | intent(in) | :: | original_lastblk | |||
logical, | intent(in) | :: | keep_sparsity |
SUBROUTINE dbcsr_mm_csr_red3D(this, meta_buffer, data_buffer, flop, m_sizes, n_sizes, & !! Make the reduction of the 3D layers in the local csr object g2l_map_rows, g2l_map_cols, original_lastblk, & keep_sparsity) TYPE(dbcsr_mm_csr_type), INTENT(INOUT) :: this INTEGER, DIMENSION(:), INTENT(IN), TARGET :: meta_buffer TYPE(dbcsr_data_obj), INTENT(IN) :: data_buffer INTEGER(KIND=int_8), INTENT(INOUT) :: flop INTEGER, DIMENSION(:), INTENT(IN) :: m_sizes, n_sizes, g2l_map_rows, & g2l_map_cols INTEGER, INTENT(IN) :: original_lastblk LOGICAL, INTENT(IN) :: keep_sparsity INTEGER :: c_blk_id, iblock, ithread, lb, lb_data, & lb_meta, nblks_max, nblocks, nthreads, & nze, nze_max, ub_meta INTEGER, DIMENSION(:), POINTER :: blk_p, col_i, row_i LOGICAL :: block_exists ithread = 0; nthreads = 1 !$ ithread = OMP_GET_THREAD_NUM(); nthreads = OMP_GET_NUM_THREADS() lb_meta = meta_buffer(ithread + 1) nblocks = (meta_buffer(ithread + 2) - lb_meta)/3 ub_meta = lb_meta + nblocks row_i => meta_buffer(lb_meta + 1:ub_meta) lb_meta = ub_meta ub_meta = lb_meta + nblocks col_i => meta_buffer(lb_meta + 1:ub_meta) ! Make local indexing if needed IF (keep_sparsity) THEN DO iblock = 1, original_lastblk row_i(iblock) = g2l_map_rows(row_i(iblock)) col_i(iblock) = g2l_map_cols(col_i(iblock)) END DO END IF lb_meta = ub_meta ub_meta = lb_meta + nblocks blk_p => meta_buffer(lb_meta + 1:ub_meta) ! ! Get sizes nze_max = this%product_wm%datasize nblks_max = this%product_wm%lastblk DO iblock = 1, nblocks nze = m_sizes(row_i(iblock))*n_sizes(col_i(iblock)) IF (nze .EQ. 0) CYCLE c_blk_id = hash_table_get(this%c_hashes(row_i(iblock)), col_i(iblock)) block_exists = c_blk_id .GT. 0 IF (block_exists) CYCLE nblks_max = nblks_max + 1 nze_max = nze_max + nze END DO ! Resize buffers CALL dbcsr_data_ensure_size(this%product_wm%data_area, & nze_max, factor=default_resize_factor, nocopy=.FALSE., & zero_pad=.TRUE.) CALL ensure_array_size(this%product_wm%row_i, ub=nblks_max, & factor=default_resize_factor, nocopy=.FALSE.) CALL ensure_array_size(this%product_wm%col_i, ub=nblks_max, & factor=default_resize_factor, nocopy=.FALSE.) CALL ensure_array_size(this%product_wm%blk_p, ub=nblks_max, & factor=default_resize_factor, nocopy=.FALSE.) DO iblock = 1, nblocks nze = m_sizes(row_i(iblock))*n_sizes(col_i(iblock)) IF (nze .EQ. 0) CYCLE lb_data = blk_p(iblock) c_blk_id = hash_table_get(this%c_hashes(row_i(iblock)), col_i(iblock)) block_exists = c_blk_id .GT. 0 IF (block_exists) THEN lb = this%product_wm%blk_p(c_blk_id) CALL block_add(this%product_wm%data_area, data_buffer, & lb, lb_data, nze) flop = flop + nze ELSE lb = this%product_wm%datasize + 1 this%product_wm%lastblk = this%product_wm%lastblk + 1 this%product_wm%datasize = this%product_wm%datasize + nze c_blk_id = this%product_wm%lastblk ! assign a new c-block-id CALL hash_table_add(this%c_hashes(row_i(iblock)), col_i(iblock), c_blk_id) this%product_wm%row_i(this%product_wm%lastblk) = row_i(iblock) this%product_wm%col_i(this%product_wm%lastblk) = col_i(iblock) this%product_wm%blk_p(this%product_wm%lastblk) = lb ! CALL dbcsr_block_copy_aa(this%product_wm%data_area, data_buffer, & m_sizes(row_i(iblock)), n_sizes(col_i(iblock)), lb, lb_data) END IF END DO CALL dbcsr_mm_sched_set_orig_datasize(this%sched, this%product_wm%datasize) END SUBROUTINE dbcsr_mm_csr_red3D