dbcsr_mm_csr_red3D Subroutine

public subroutine dbcsr_mm_csr_red3D(this, meta_buffer, data_buffer, flop, m_sizes, n_sizes, g2l_map_rows, g2l_map_cols, original_lastblk, keep_sparsity)

Make the reduction of the 3D layers in the local csr object

Arguments

Type IntentOptional 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

Source Code

   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