dbcsr_replicate Subroutine

private subroutine dbcsr_replicate(matrix, replicate_rows, replicate_columns, restrict_source)

Replicates a DBCSR matrix among process rows and columns

Direction definition Row replication means that all processors in a process grid sharing the same row get the data of the entire row. (In a 1-column grid the operation has no effect.) Similar logic applies to column replication.

Arguments

TypeIntentOptionalAttributesName
type(dbcsr_type), intent(inout) :: matrix

matrix to replicate

logical, intent(in) :: replicate_rows

Row should be replicated among all processors Column should be replicated among all processors

logical, intent(in) :: replicate_columns

Row should be replicated among all processors Column should be replicated among all processors

integer, intent(in), optional :: restrict_source

Send only from this node (ignores blocks on other nodes)


Contents

Source Code


Source Code

   SUBROUTINE dbcsr_replicate(matrix, replicate_rows, replicate_columns, &
                              restrict_source)
      !! Replicates a DBCSR matrix among process rows and columns
      !!
      !! Direction definition
      !! Row replication means that all processors in a process grid sharing
      !! the same row get the data of the entire row. (In a 1-column grid the
      !! operation has no effect.) Similar logic applies to column replication.

      TYPE(dbcsr_type), INTENT(INOUT)                    :: matrix
         !! matrix to replicate
      LOGICAL, INTENT(IN)                                :: replicate_rows, replicate_columns
         !! Row should be replicated among all processors
         !! Column should be replicated among all processors
      INTEGER, INTENT(IN), OPTIONAL                      :: restrict_source
         !! Send only from this node (ignores blocks on other nodes)

      CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_replicate'
      INTEGER, PARAMETER                                 :: metalen = 3
      LOGICAL, PARAMETER                                 :: dbg = .FALSE.

      CHARACTER                                          :: rep_type
      INTEGER :: blk, blk_l, blk_p, blk_ps, blks, col, col_size, data_type, dst_p, handle, &
                 mp_group, mynode, mypcol, myprow, nblks, numnodes, nze, offset, row, row_size, smp, &
                 src_p, stored_blk_p, stored_col, stored_row
      INTEGER, ALLOCATABLE, DIMENSION(:)                 :: rd_disp, recv_meta, rm_disp, send_meta
      INTEGER, ALLOCATABLE, DIMENSION(:, :)              :: recv_count
      INTEGER, DIMENSION(2)                              :: send_count
      INTEGER, DIMENSION(:), POINTER, CONTIGUOUS         :: col_blk_size, col_dist, row_blk_size, &
                                                            row_dist, tmp_index
      INTEGER, DIMENSION(:, :), POINTER                  :: blacs2mpi
      LOGICAL                                            :: had_subcomms, i_am_restricted, rest_src, &
                                                            tr
      TYPE(dbcsr_data_obj)                               :: data_block, recv_data, send_data, &
                                                            tmp_data
      TYPE(dbcsr_distribution_obj)                       :: target_dist
      TYPE(dbcsr_iterator)                               :: iter
      TYPE(dbcsr_mp_obj)                                 :: mp_obj
      TYPE(dbcsr_type)                                   :: replicated

!   ---------------------------------------------------------------------------

      CALL timeset(routineN, handle)
      IF (.NOT. dbcsr_valid_index(matrix)) &
         DBCSR_ABORT("Matrix not initialized.")
      !IF(matrix%replication_type /= dbcsr_repl_none) &
      !   DBCSR_WARN("Replicating a non-distributed matrix makes no sense.")
      IF (replicate_rows .AND. replicate_columns) THEN
         rep_type = dbcsr_repl_full
      ELSEIF (replicate_rows .AND. .NOT. replicate_columns) THEN
         rep_type = dbcsr_repl_row
      ELSEIF (replicate_columns .AND. .NOT. replicate_rows) THEN
         rep_type = dbcsr_repl_col
      ELSE
         rep_type = dbcsr_repl_none
         IF (.NOT. replicate_rows .AND. .NOT. replicate_columns) &
            DBCSR_ABORT("Some replication must be specified")
      END IF
      data_type = dbcsr_get_data_type(matrix)
      row_blk_size => array_data(matrix%row_blk_size)
      col_blk_size => array_data(matrix%col_blk_size)
      target_dist = matrix%dist
      row_dist => dbcsr_distribution_row_dist(target_dist)
      col_dist => dbcsr_distribution_col_dist(target_dist)
      mp_obj = dbcsr_distribution_mp(target_dist)
      blacs2mpi => dbcsr_mp_pgrid(mp_obj)
      numnodes = dbcsr_mp_numnodes(mp_obj)
      mynode = dbcsr_mp_mynode(mp_obj)
      myprow = dbcsr_mp_myprow(mp_obj)
      mypcol = dbcsr_mp_mypcol(mp_obj)
      IF (MAXVAL(row_dist) .GT. UBOUND(blacs2mpi, 1)) &
         DBCSR_ABORT('Row distribution references unexistent processor rows')
      IF (dbg) THEN
         IF (MAXVAL(row_dist) .NE. UBOUND(blacs2mpi, 1)) &
            DBCSR_WARN('Range of row distribution not equal to processor rows')
      END IF
      IF (MAXVAL(col_dist) .GT. UBOUND(blacs2mpi, 2)) &
         DBCSR_ABORT('Col distribution references unexistent processor cols')
      IF (dbg) THEN
         IF (MAXVAL(col_dist) .NE. UBOUND(blacs2mpi, 2)) &
            DBCSR_WARN('Range of col distribution not equal to processor cols')
      END IF
      ! Define the number of nodes with which I will communicate. Also
      ! setup row and column communicators.
      had_subcomms = dbcsr_mp_has_subgroups(mp_obj)
      SELECT CASE (rep_type)
      CASE (dbcsr_repl_full)
         numnodes = dbcsr_mp_numnodes(mp_obj)
         mp_group = dbcsr_mp_group(mp_obj)
         mynode = dbcsr_mp_mynode(mp_obj)
      CASE (dbcsr_repl_row)
         numnodes = dbcsr_mp_npcols(mp_obj)
         CALL dbcsr_mp_grid_setup(mp_obj)
         mp_group = dbcsr_mp_my_row_group(mp_obj)
         mynode = dbcsr_mp_mypcol(mp_obj)
      CASE (dbcsr_repl_col)
         numnodes = dbcsr_mp_nprows(mp_obj)
         CALL dbcsr_mp_grid_setup(mp_obj)
         mp_group = dbcsr_mp_my_col_group(mp_obj)
         mynode = dbcsr_mp_myprow(mp_obj)
      CASE (dbcsr_repl_none)
         numnodes = 1
         mp_group = dbcsr_mp_group(mp_obj)
         mynode = 0
      END SELECT
      IF ((rep_type == dbcsr_repl_row .OR. rep_type == dbcsr_repl_col) .AND. .NOT. dbcsr_mp_has_subgroups(mp_obj)) &
         DBCSR_ABORT("Only full replication supported when subcommunicators are turned off.")
      !
      IF (PRESENT(restrict_source)) THEN
         rest_src = .TRUE.
         i_am_restricted = mynode .NE. restrict_source
      ELSE
         rest_src = .FALSE.
         i_am_restricted = .FALSE.
      END IF
      !
      ALLOCATE (recv_count(2, 0:numnodes - 1))
      ALLOCATE (rd_disp(0:numnodes - 1))
      ALLOCATE (rm_disp(0:numnodes - 1))
      CALL dbcsr_create(replicated, name='Replicated '//TRIM(matrix%name), &
                        template=matrix, &
                        matrix_type=dbcsr_type_no_symmetry, &
                        replication_type=rep_type)
      !
      ! Count initial sizes for sending. Also, ensure that blocks are on their
      ! home processors.
      send_count(1:2) = 0
      CALL dbcsr_iterator_start(iter, matrix)
      IF (.NOT. i_am_restricted) THEN
         DO WHILE (dbcsr_iterator_blocks_left(iter))
            CALL dbcsr_iterator_next_block(iter, row, col, &
                                           row_size=row_size, col_size=col_size, blk=blk)
            !tr = .FALSE.
            !CALL dbcsr_get_stored_coordinates (matrix, row, col, tr, dst_p)
            !IF(dst_p /= mynode) &
            !   DBCSR_ABORT("Matrix is not correctly distributed. Call dbcsr_redistribute.")
            nze = row_size*col_size
            send_count(1) = send_count(1) + 1
            send_count(2) = send_count(2) + nze
         END DO
         send_count(2) = dbcsr_data_get_size_referenced(matrix%data_area)
      END IF
      CALL dbcsr_iterator_stop(iter)
      ! Exchange how much data others have.
      CALL mp_allgather(send_count(1:2), recv_count, mp_group)
      CALL dbcsr_data_init(recv_data)
      nze = SUM(recv_count(2, :))
      nblks = SUM(recv_count(1, :))
      CALL dbcsr_data_new(recv_data, data_type=data_type, data_size=nze)
      ! send_data should have the correct size
      CALL dbcsr_data_init(send_data)
      IF (send_count(2) .EQ. 0) THEN
         CALL dbcsr_data_new(send_data, data_type=data_type, data_size=0)
      ELSE
         CALL dbcsr_data_new(send_data, data_type=data_type)
         send_data = pointer_view(send_data, matrix%data_area, 1, send_count(2))
      END IF
      ALLOCATE (recv_meta(metalen*nblks))
      ALLOCATE (send_meta(metalen*send_count(1)))
      recv_meta(:) = 0
      ! Fill in the meta data structures and copy the data.
      rd_disp = -1; rm_disp = -1
      rd_disp(0) = 1; rm_disp(0) = 1
      DO dst_p = 1, numnodes - 1
         rm_disp(dst_p) = rm_disp(dst_p - 1) &
                          + metalen*recv_count(1, dst_p - 1)
         rd_disp(dst_p) = rd_disp(dst_p - 1) &
                          + recv_count(2, dst_p - 1)
      END DO
      CALL dbcsr_data_init(data_block)
      CALL dbcsr_data_new(data_block, data_type=data_type)
      CALL dbcsr_iterator_start(iter, matrix)
      smp = 1
      IF (.NOT. i_am_restricted) THEN
         DO WHILE (dbcsr_iterator_blocks_left(iter))
            CALL dbcsr_iterator_next_block(iter, row, col, blk, &
                                           transposed=tr, blk_p=blk_p)
            send_meta(smp + 0) = row
            send_meta(smp + 1) = col
            send_meta(smp + 2) = blk_p
            smp = smp + metalen
         END DO
      END IF
      CALL dbcsr_iterator_stop(iter)
      CALL dbcsr_data_clear_pointer(data_block)
      CALL dbcsr_data_release(data_block)
      ! Exchange the data and metadata structures.
      CALL mp_allgather(send_meta, recv_meta, metalen*recv_count(1, :), &
                        rm_disp - 1, mp_group)
      CALL dbcsr_allgatherv(send_data, dbcsr_data_get_size(send_data), &
                            recv_data, recv_count(2, :), &
                            rd_disp - 1, mp_group)
      ! Release the send buffer. If it had a non-zero size then it was a
      ! pointer into the regular matrix and the data pointer should be
      ! cleared and not deallocated.
      IF (send_count(2) .NE. 0) THEN
         CALL dbcsr_data_clear_pointer(send_data)
      END IF
      CALL dbcsr_data_release(send_data)
      !
      ! Now fill in the data.
      CALL dbcsr_work_create(replicated, &
                             SUM(recv_count(1, :)), &
                             SUM(recv_count(2, :)), n=1, &
                             work_mutable=.FALSE.)
      CALL dbcsr_data_hold(recv_data)
      CALL dbcsr_data_release(replicated%wms(1)%data_area)
      replicated%wms(1)%data_area = recv_data
      blk_ps = 1
      blks = 1
      DO src_p = 0, numnodes - 1
         nze = recv_count(2, src_p)
         !CALL dbcsr_data_set (replicated%wms(1)%data_area, blk_ps, nze,&
         !     recv_data, rd_disp(src_p))
         offset = rd_disp(src_p) - 1
         DO blk_l = 1, recv_count(1, src_p)
            IF (dbg) WRITE (*, *) "src_p, blk_l", src_p, blk_l
            stored_row = recv_meta(rm_disp(src_p) + metalen*(blk_l - 1))
            stored_col = recv_meta(rm_disp(src_p) + metalen*(blk_l - 1) + 1)
            stored_blk_p = recv_meta(rm_disp(src_p) + metalen*(blk_l - 1) + 2)
            replicated%wms(1)%row_i(blks) = stored_row
            replicated%wms(1)%col_i(blks) = stored_col
            replicated%wms(1)%blk_p(blks) = SIGN(ABS(stored_blk_p) + offset, &
                                                 stored_blk_p)
            nze = row_blk_size(stored_row) &
                  *col_blk_size(stored_col)
            blk_ps = MAX(blk_ps, ABS(stored_blk_p) + nze + offset)
            blks = blks + 1
         END DO
      END DO
      CALL dbcsr_data_set_size_referenced(replicated%wms(1)%data_area, blk_ps - 1)
      !
      replicated%wms(1)%lastblk = blks - 1
      replicated%wms(1)%datasize = blk_ps - 1
      CALL dbcsr_finalize(replicated, reshuffle=.TRUE.)
      !
      ! Remove communicators if they were forcibly created.
      IF (had_subcomms .AND. &
          (rep_type .EQ. dbcsr_repl_row .OR. rep_type .EQ. dbcsr_repl_col)) THEN
         CALL dbcsr_mp_grid_remove(mp_obj)
      END IF
      DEALLOCATE (recv_count)
      DEALLOCATE (rd_disp)
      DEALLOCATE (rm_disp)
      CALL dbcsr_data_release(recv_data)
      DEALLOCATE (recv_meta)
      DEALLOCATE (send_meta)
      matrix%replication_type = replicated%replication_type
      ! Now replace the data and index
      CALL dbcsr_switch_data_area(matrix, replicated%data_area, &
                                  previous_data_area=tmp_data)
      CALL dbcsr_switch_data_area(replicated, tmp_data)
      CALL dbcsr_data_release(tmp_data)
      tmp_index => matrix%index
      matrix%index => replicated%index
      replicated%index => tmp_index
      CALL dbcsr_repoint_index(matrix)
      matrix%nze = replicated%nze
      matrix%nblks = replicated%nblks
      CALL dbcsr_release(replicated)
      CALL dbcsr_verify_matrix(matrix)
      CALL timestop(handle)
   END SUBROUTINE dbcsr_replicate