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