prepare_buffers_d Subroutine

private subroutine prepare_buffers_d(negate_real, negate_imaginary, iter, row, col, blk, blk_p, bp, row_size, col_size, nze, nsymmetries, symmetry_i, stored_row, stored_col, tr_row_size, tr_col_size, tr, row_img, col_img, nrow_images, ncol_images, row_img_dist, col_img_dist, predist_type_fwd, blacs2mpi, target_imgdist, prow, pcol, rowi, coli, row_dist, col_dist, dst_p, sm_pos, myt_smp, metalen, sd_pos, myt_sdp, send_meta, sd_disp, data_area, send_data_area, scale_neg_one, scale_value)

Prepare buffers for multiplications

Arguments

TypeIntentOptionalAttributesName
logical, intent(in) :: negate_real
logical, intent(in) :: negate_imaginary
type(dbcsr_iterator), intent(inout) :: iter
integer, intent(inout) :: row
integer, intent(inout) :: col
integer, intent(inout) :: blk
integer, intent(inout) :: blk_p
integer, intent(inout) :: bp
integer, intent(inout) :: row_size
integer, intent(inout) :: col_size
integer, intent(inout) :: nze
integer, intent(in) :: nsymmetries
integer, intent(inout) :: symmetry_i
integer, intent(inout) :: stored_row
integer, intent(inout) :: stored_col
integer, intent(inout) :: tr_row_size
integer, intent(inout) :: tr_col_size
logical, intent(inout) :: tr
integer, intent(inout) :: row_img
integer, intent(inout) :: col_img
integer, intent(in) :: nrow_images
integer, intent(in) :: ncol_images
integer, intent(in), DIMENSION(:), CONTIGUOUS, POINTER:: row_img_dist
integer, intent(in), DIMENSION(:), CONTIGUOUS, POINTER:: col_img_dist
character, intent(in) :: predist_type_fwd
integer, intent(in), DIMENSION(:, :), CONTIGUOUS, POINTER:: blacs2mpi
type(dbcsr_imagedistribution_obj), intent(in) :: target_imgdist
integer, intent(inout) :: prow
integer, intent(inout) :: pcol
integer, intent(inout) :: rowi
integer, intent(inout) :: coli
integer, intent(in), DIMENSION(:), CONTIGUOUS, POINTER:: row_dist
integer, intent(in), DIMENSION(:), CONTIGUOUS, POINTER:: col_dist
integer, intent(inout) :: dst_p
integer, intent(inout) :: sm_pos
integer, intent(inout), DIMENSION(:), ALLOCATABLE:: myt_smp
integer, intent(in) :: metalen
integer, intent(inout) :: sd_pos
integer, intent(inout), DIMENSION(:), ALLOCATABLE:: myt_sdp
integer, intent(inout), DIMENSION(:), ALLOCATABLE:: send_meta
integer, intent(in), DIMENSION(:), ALLOCATABLE:: sd_disp
real(kind=real_8), intent(in), DIMENSION(:), CONTIGUOUS:: data_area
type(dbcsr_data_obj), intent(inout) :: send_data_area
type(dbcsr_scalar_type), intent(in) :: scale_neg_one
type(dbcsr_scalar_type), intent(in), optional :: scale_value

Contents

Source Code


Source Code

      SUBROUTINE prepare_buffers_d (negate_real, negate_imaginary, &
                                                iter, row, col, blk, blk_p, bp, &
                                                row_size, col_size, nze, nsymmetries, symmetry_i, &
                                                stored_row, stored_col, tr_row_size, tr_col_size, tr, &
                                                row_img, col_img, nrow_images, ncol_images, &
                                                row_img_dist, col_img_dist, predist_type_fwd, blacs2mpi, &
                                                target_imgdist, prow, pcol, rowi, coli, &
                                                row_dist, col_dist, dst_p, sm_pos, myt_smp, metalen, &
                                                sd_pos, myt_sdp, send_meta, sd_disp, &
                                                data_area, send_data_area, scale_neg_one, scale_value)
     !! Prepare buffers for multiplications
         LOGICAL, INTENT(IN)                                     :: negate_real, negate_imaginary
         TYPE(dbcsr_iterator), INTENT(INOUT)                     :: iter
         INTEGER, INTENT(INOUT)                                  :: row, col, blk, blk_p, row_size, col_size, &
                                                                    nze, bp, symmetry_i, &
                                                                    stored_row, stored_col, tr_row_size, tr_col_size, &
                                                                    row_img, col_img, prow, pcol, rowi, coli, &
                                                                    dst_p, sm_pos, sd_pos
         INTEGER, INTENT(IN)                                     :: nsymmetries, nrow_images, ncol_images, metalen
         LOGICAL, INTENT(INOUT)                                  :: tr
         INTEGER, DIMENSION(:), INTENT(IN), CONTIGUOUS, POINTER  :: row_img_dist, col_img_dist, row_dist, col_dist
         INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(IN)          :: sd_disp
         INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(INOUT)       :: myt_smp, myt_sdp, send_meta
         TYPE(dbcsr_imagedistribution_obj), INTENT(IN)           :: target_imgdist
         INTEGER, DIMENSION(:, :), INTENT(IN), CONTIGUOUS, POINTER :: blacs2mpi
         CHARACTER, INTENT(IN)                                   :: predist_type_fwd
         REAL(kind=real_8), DIMENSION(:), INTENT(IN), CONTIGUOUS         :: data_area
         TYPE(dbcsr_data_obj), INTENT(INOUT)                     :: send_data_area
         TYPE(dbcsr_scalar_type), INTENT(IN)                     :: scale_neg_one
         TYPE(dbcsr_scalar_type), INTENT(IN), OPTIONAL           :: scale_value

         DO WHILE (dbcsr_iterator_blocks_left(iter))
            CALL dbcsr_iterator_next_block(iter, row, col, blk, blk_p=blk_p, &
                                           row_size=row_size, col_size=col_size)
            nze = row_size*col_size
            IF (nze .EQ. 0) CYCLE
            bp = ABS(blk_p)
            DO symmetry_i = 1, nsymmetries
               IF (symmetry_i .EQ. 1) THEN
                  stored_row = row; stored_col = col; tr = blk_p .LT. 0
                  tr_row_size = col_size; tr_col_size = row_size
               ELSE
                  IF (row .EQ. col) CYCLE
                  stored_row = col; stored_col = row; tr = blk_p .GT. 0
                  tr_row_size = row_size; tr_col_size = col_size
               END IF
               ! Where do we send this block?
               row_img = 1
               IF (nrow_images .GT. 1) row_img = row_img_dist(stored_row)
               col_img = 1
               IF (ncol_images .GT. 1) col_img = col_img_dist(stored_col)
               CALL image_calculator(target_imgdist, &
                                     prow=prow, rowi=rowi, &
                                     pcol=pcol, coli=coli, &
                                     myprow=row_dist(stored_row), myrowi=row_img, &
                                     mypcol=col_dist(stored_col), mycoli=col_img, &
                                     shifting=predist_type_fwd)
               dst_p = blacs2mpi(prow, pcol)
               sm_pos = myt_smp(dst_p)
               myt_smp(dst_p) = myt_smp(dst_p) + metalen
               sd_pos = myt_sdp(dst_p)
               myt_sdp(dst_p) = myt_sdp(dst_p) + nze
               IF (tr) THEN
                  IF (PRESENT(scale_value)) THEN
                     CALL dbcsr_block_transpose(send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1), &
                                                data_area(bp:bp + nze - 1)*scale_value%r_dp, &
                                                tr_row_size, tr_col_size)
                  ELSE
                     CALL dbcsr_block_transpose(send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1), &
                                                data_area(bp:bp + nze - 1), &
                                                tr_row_size, tr_col_size)
                  END IF
                  IF (negate_real .AND. negate_imaginary) THEN
                     send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1) = &
                        send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1)*scale_neg_one%r_dp
                  ELSEIF (negate_real) THEN
# 2001 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_cannon.F"
                        send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1) = &
                           -send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1)
# 2010 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_cannon.F"
                  ELSEIF (negate_imaginary) THEN
# 2015 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_cannon.F"
                  END IF
               ELSE
                  ! Copy the block
                  IF (PRESENT(scale_value)) THEN
                     send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1) = &
                        data_area(bp:bp + nze - 1)*scale_value%r_dp
                  ELSE
                     send_data_area%d%r_dp (sd_pos:myt_sdp(dst_p) - 1) = data_area(bp:bp + nze - 1)
                  END IF
               END IF

               send_meta(sm_pos) = stored_row
               send_meta(sm_pos + 1) = stored_col
               send_meta(sm_pos + 2) = sd_pos - sd_disp(dst_p) + 1
               send_meta(sm_pos + 3) = rowi
               send_meta(sm_pos + 4) = coli
            END DO
         END DO
      END SUBROUTINE prepare_buffers_d