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 # 2006 "/__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) # 2015 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_cannon.F" ELSEIF (negate_imaginary) THEN # 2020 "/__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