Prepare buffers for multiplications
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| 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(len=1), | 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 |
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
# 2004 "/__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)
# 2013 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_cannon.F"
ELSEIF (negate_imaginary) THEN
# 2018 "/__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