# 1 "/__w/dbcsr/dbcsr/src/mm/dbcsr_mm_dist_operations.F" 1 !--------------------------------------------------------------------------------------------------! ! Copyright (C) by the DBCSR developers group - All rights reserved ! ! This file is part of the DBCSR library. ! ! ! ! For information on the license, see the LICENSE file. ! ! For further information please visit https://dbcsr.cp2k.org ! ! SPDX-License-Identifier: GPL-2.0+ ! !--------------------------------------------------------------------------------------------------! MODULE dbcsr_mm_dist_operations !! DBCSR operations on distributions related to matrix multiplication USE dbcsr_array_types, ONLY: & array_data, array_equality, array_exists, array_hold, array_i1d_obj, array_new, & array_nullify, array_release, array_size USE dbcsr_dist_methods, ONLY: & dbcsr_distribution_col_dist, dbcsr_distribution_has_threads, dbcsr_distribution_hold, & dbcsr_distribution_make_threads, dbcsr_distribution_mp, dbcsr_distribution_ncols, & dbcsr_distribution_new, dbcsr_distribution_no_threads, dbcsr_distribution_nrows, & dbcsr_distribution_release, dbcsr_distribution_row_dist, dbcsr_distribution_thread_dist USE dbcsr_dist_operations, ONLY: dbcsr_get_local_cols, & dbcsr_get_local_rows, & find_all_local_elements, & rebin_distribution USE dbcsr_methods, ONLY: dbcsr_distribution, & dbcsr_release_locals USE dbcsr_mp_methods, ONLY: dbcsr_mp_mypcol, & dbcsr_mp_myprow, & dbcsr_mp_npcols, & dbcsr_mp_nprows USE dbcsr_toollib, ONLY: gcd USE dbcsr_types, ONLY: & dbcsr_distribution_obj, dbcsr_imagedistribution_obj, dbcsr_mp_obj, dbcsr_slot_home_pcol, & dbcsr_slot_home_prow, dbcsr_slot_home_vpcol, dbcsr_slot_home_vprow, & dbcsr_slot_nblkcols_local, dbcsr_slot_nblkrows_local, dbcsr_type #include "base/dbcsr_base_uses.f90" IMPLICIT NONE PRIVATE INTEGER :: idid = 0 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_mm_dist_operations' PUBLIC :: dbcsr_create_image_dist, dbcsr_make_dists_dense PUBLIC :: image_calculator, make_sizes_dense PUBLIC :: dbcsr_reset_locals, dbcsr_reset_vlocals PUBLIC :: dbcsr_get_local_vrows, dbcsr_get_local_vcols LOGICAL, PARAMETER :: careful_mod = .FALSE. LOGICAL, PARAMETER :: debug_mod = .FALSE. CONTAINS SUBROUTINE dbcsr_create_image_dist(imgdist, dist, & match_row_pdist, match_row_idist, match_row_nbins, & match_col_pdist, match_col_idist, match_col_nbins, & nimages_rows, nimages_cols) !! Creates an image distribution given the other compatibility images TYPE(dbcsr_imagedistribution_obj), INTENT(OUT) :: imgdist !! distribution repetition TYPE(dbcsr_distribution_obj), INTENT(IN) :: dist !! distribution for which to form the image distribution INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: match_row_pdist, match_row_idist !! match the new row distribution to this row distribution !! match the row distribution to these row images INTEGER, INTENT(IN) :: match_row_nbins !! number of bins in the distribution to match the local rows INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: match_col_pdist, match_col_idist !! match the new column distribution to this column distribution !! match the new column distribution to these column images INTEGER, INTENT(IN) :: match_col_nbins, nimages_rows, & nimages_cols !! number of bins in the distribution to match the local columns CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_create_image_dist' INTEGER :: ncols, npcols, nprows, nrows INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: col_dist_data, col_img_data, col_vdist, & row_dist_data, row_img_data, row_vdist LOGICAL :: new_col_dist, new_row_dist TYPE(dbcsr_distribution_obj) :: new_dist TYPE(dbcsr_mp_obj) :: mp_env ! --------------------------------------------------------------------------- idid = idid + 1 ALLOCATE (imgdist%i) imgdist%i%refcount = 1 imgdist%i%id = idid mp_env = dbcsr_distribution_mp(dist) ! Determine the factors. nrows = dbcsr_distribution_nrows(dist) ncols = dbcsr_distribution_ncols(dist) nprows = dbcsr_mp_nprows(mp_env) npcols = dbcsr_mp_npcols(mp_env) IF (debug_mod) WRITE (*, '(1X,A,I5,"x",I5)') routineN//"pgrid", & nprows, npcols ! ! Create the new row distribution and row image distribution imgdist%i%row_decimation = nimages_rows/nprows imgdist%i%row_multiplicity = nimages_rows/gcd(nimages_rows, match_row_nbins) new_row_dist = .FALSE. ! IF (debug_mod) WRITE (*, *) routineN//'row decimation, multiplicity', & imgdist%i%row_decimation, imgdist%i%row_multiplicity IF (debug_mod) WRITE (*, *) routineN//" nprows, match prows", nprows, match_row_nbins ALLOCATE (row_img_data(nrows)) ALLOCATE (row_vdist(nrows)) ! IF (imgdist%i%row_decimation .EQ. 1 .AND. imgdist%i%row_multiplicity .EQ. 1 .AND. & .NOT. PRESENT(match_row_pdist)) THEN row_dist_data => dbcsr_distribution_row_dist(dist) row_img_data(:) = 1 ELSE IF (PRESENT(match_row_pdist)) THEN ALLOCATE (row_dist_data(nrows)) new_row_dist = .TRUE. IF (PRESENT(match_row_idist)) THEN CALL rebin_imaged_distribution(row_dist_data, row_img_data, & match_row_pdist, match_row_idist, & nprows, & imgdist%i%row_multiplicity, imgdist%i%row_decimation) ELSE CALL rebin_distribution(row_dist_data, row_img_data, & match_row_pdist, & nprows, & imgdist%i%row_multiplicity, imgdist%i%row_decimation) END IF ELSE row_dist_data => dbcsr_distribution_row_dist(dist) CALL reimage_distribution(row_img_data, & row_dist_data, nprows, imgdist%i%row_decimation) END IF END IF CALL make_vdistribution(nrows, row_vdist, row_dist_data, & imgdist%i%row_decimation, row_img_data) CALL array_new(imgdist%i%vrow_dist, row_vdist, gift=.TRUE.) ! ! Create the new column distribution and column image distribution imgdist%i%col_decimation = nimages_cols/npcols imgdist%i%col_multiplicity = nimages_cols/gcd(nimages_cols, match_col_nbins) new_col_dist = .FALSE. ! IF (debug_mod) WRITE (*, *) routineN//'col decimation, multiplicity', & imgdist%i%col_decimation, imgdist%i%col_multiplicity IF (debug_mod) WRITE (*, *) routineN//" npcols, match pcols", npcols, match_col_nbins ALLOCATE (col_img_data(ncols)) ALLOCATE (col_vdist(ncols)) ! IF (imgdist%i%col_decimation .EQ. 1 .AND. imgdist%i%col_multiplicity .EQ. 1 .AND. & .NOT. PRESENT(match_col_pdist)) THEN col_dist_data => dbcsr_distribution_col_dist(dist) col_img_data(:) = 1 ELSE IF (PRESENT(match_col_pdist)) THEN ALLOCATE (col_dist_data(ncols)) new_col_dist = .TRUE. IF (PRESENT(match_col_idist)) THEN CALL rebin_imaged_distribution(col_dist_data, col_img_data, & match_col_pdist, match_col_idist, & npcols, & imgdist%i%col_multiplicity, imgdist%i%col_decimation) ELSE CALL rebin_distribution(col_dist_data, col_img_data, & match_col_pdist, & npcols, & imgdist%i%col_multiplicity, imgdist%i%col_decimation) END IF ELSE col_dist_data => dbcsr_distribution_col_dist(dist) CALL reimage_distribution(col_img_data, & col_dist_data, & npcols, imgdist%i%col_decimation) END IF END IF CALL make_vdistribution(ncols, col_vdist, col_dist_data, & imgdist%i%col_decimation, col_img_data) CALL array_new(imgdist%i%vcol_dist, col_vdist, gift=.TRUE.) ! ! Copy the row & column distribution from old distribution IF (new_row_dist .AND. new_col_dist) THEN CALL dbcsr_distribution_new(new_dist, & mp_env, & row_dist_data, col_dist_data, & reuse_arrays=.TRUE.) ELSE CALL dbcsr_distribution_new(new_dist, & mp_env, & row_dist_data, col_dist_data) IF (new_row_dist) DEALLOCATE (row_dist_data) IF (new_col_dist) DEALLOCATE (col_dist_data) END IF ! Now finish the distribution image. imgdist%i%main = new_dist CALL array_new(imgdist%i%col_image, col_img_data, gift=.TRUE.) CALL array_new(imgdist%i%row_image, row_img_data, gift=.TRUE.) ! imgdist%i%has_other_vl_rows = .FALSE. imgdist%i%has_other_vl_cols = .FALSE. imgdist%i%has_global_vrow_map = .FALSE. imgdist%i%has_global_vcol_map = .FALSE. ! !$ IF (dbcsr_distribution_has_threads(dist)) THEN !$ imgdist%i%main%d%num_threads = dist%d%num_threads !$ imgdist%i%main%d%has_thread_dist = .TRUE. !$ imgdist%i%main%d%thread_dist = dist%d%thread_dist !$ CALL array_hold(imgdist%i%main%d%thread_dist) !$ END IF END SUBROUTINE dbcsr_create_image_dist SUBROUTINE dbcsr_new_image_dist(imgdist, dist, & template) TYPE(dbcsr_imagedistribution_obj), INTENT(OUT) :: imgdist TYPE(dbcsr_distribution_obj), INTENT(IN) :: dist TYPE(dbcsr_imagedistribution_obj), INTENT(IN) :: template ! --------------------------------------------------------------------------- idid = idid + 1 ALLOCATE (imgdist%i) imgdist%i%refcount = 1 imgdist%i%id = idid imgdist%i%row_decimation = template%i%row_decimation imgdist%i%row_multiplicity = template%i%row_multiplicity imgdist%i%col_decimation = template%i%col_decimation imgdist%i%col_multiplicity = template%i%col_multiplicity ! NULLIFY (imgdist%i%other_vl_rows) NULLIFY (imgdist%i%other_vl_cols) CALL array_nullify(imgdist%i%global_vrow_map) CALL array_nullify(imgdist%i%global_vcol_map) imgdist%i%has_other_vl_rows = .FALSE. imgdist%i%has_other_vl_cols = .FALSE. imgdist%i%has_global_vrow_map = .FALSE. imgdist%i%has_global_vcol_map = .FALSE. ! imgdist%i%main = dist CALL dbcsr_distribution_hold(imgdist%i%main) ! END SUBROUTINE dbcsr_new_image_dist SUBROUTINE dbcsr_make_dists_dense(product_dist, left_rdist, right_rdist, & !! Prepares distributions for making dense matrices. dense_product_dist, dense_left_rdist, dense_right_rdist, & partial, & m_map, k_vmap, n_map, & old_m_sizes) TYPE(dbcsr_distribution_obj), INTENT(IN) :: product_dist TYPE(dbcsr_imagedistribution_obj), INTENT(IN) :: left_rdist, right_rdist TYPE(dbcsr_distribution_obj), INTENT(OUT) :: dense_product_dist TYPE(dbcsr_imagedistribution_obj), INTENT(OUT) :: dense_left_rdist, dense_right_rdist LOGICAL, INTENT(IN) :: partial TYPE(array_i1d_obj), INTENT(OUT) :: m_map, k_vmap, n_map TYPE(array_i1d_obj), INTENT(IN) :: old_m_sizes CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_make_dists_dense' INTEGER :: error_handle, i, j, k_nbins, m_nbins, & n_nbins, nthreads INTEGER, DIMENSION(:), POINTER :: tdist TYPE(array_i1d_obj) :: new_k_idist, new_k_pdist, new_k_vdist, & new_m_dist, new_m_sizes, new_n_dist, & old_k_vdist, old_m_dist, old_n_dist TYPE(dbcsr_distribution_obj) :: dense_left_dist, dense_right_dist ! --------------------------------------------------------------------------- CALL timeset(routineN, error_handle) ! IF (.NOT. dbcsr_distribution_has_threads(product_dist)) & DBCSR_ABORT("Product distribution must have threads.") tdist => array_data(dbcsr_distribution_thread_dist(product_dist)) old_m_dist = product_dist%d%row_dist_block old_n_dist = product_dist%d%col_dist_block old_k_vdist = right_rdist%i%vrow_dist m_nbins = dbcsr_mp_nprows(product_dist%d%mp_env) n_nbins = dbcsr_mp_npcols(product_dist%d%mp_env) k_nbins = dbcsr_mp_nprows(right_rdist%i%main%d%mp_env)*right_rdist%i%row_decimation IF (.NOT. array_equality(old_k_vdist, left_rdist%i%vcol_dist)) & DBCSR_ABORT("k distribution mismatch") nthreads = product_dist%d%num_threads ! IF (partial) THEN new_m_dist = old_m_dist CALL array_hold(new_m_dist) new_n_dist = old_n_dist CALL array_hold(new_n_dist) dense_product_dist = product_dist CALL dbcsr_distribution_hold(dense_product_dist) CALL array_new(m_map, (/(i, i=1, array_size(new_m_dist))/), lb=1) CALL array_new(n_map, (/(i, i=1, array_size(new_n_dist))/), lb=1) ELSE CALL dbcsr_make_1dist_dense(m_nbins, old_m_dist, new_m_dist, m_map, & nthreads, tdist) CALL dbcsr_make_1dist_dense(n_nbins, old_n_dist, new_n_dist, n_map, 0) CALL dbcsr_distribution_new(dense_product_dist, product_dist%d%mp_env, & new_m_dist, new_n_dist) CALL make_sizes_dense(old_m_sizes, m_map, array_size(new_m_dist), new_m_sizes) CALL dbcsr_distribution_make_threads(dense_product_dist, & array_data(new_m_sizes)) CALL array_release(new_m_sizes) tdist => array_data(dbcsr_distribution_thread_dist(dense_product_dist)) ! Resets the thread distribution to be in-order. DO i = 1, m_nbins tdist((i - 1)*nthreads + 1:(i)*nthreads) = (/(j, j=0, nthreads - 1)/) END DO END IF ! CALL dbcsr_make_1dist_dense(k_nbins, old_k_vdist, new_k_vdist, k_vmap, 0) CALL v_to_p_i_dist_o(new_k_vdist, & left_rdist%i%col_decimation, new_k_pdist, new_k_idist) ! Left CALL dbcsr_distribution_new(dense_left_dist, left_rdist%i%main%d%mp_env, & new_m_dist, new_k_pdist) CALL dbcsr_distribution_no_threads(dense_left_dist) dense_left_dist%d%thread_dist = dbcsr_distribution_thread_dist(dense_product_dist) CALL array_hold(dense_left_dist%d%thread_dist) dense_left_dist%d%has_thread_dist = .TRUE. CALL dbcsr_new_image_dist(dense_left_rdist, dense_left_dist, left_rdist) CALL dbcsr_distribution_release(dense_left_dist) CALL array_new(dense_left_rdist%i%row_image, & (/(1, i=1, array_size(new_m_dist))/), lb=1) dense_left_rdist%i%col_image = new_k_idist CALL array_hold(new_k_idist) dense_left_rdist%i%vrow_dist = new_m_dist CALL array_hold(new_m_dist) dense_left_rdist%i%vcol_dist = new_k_vdist CALL array_hold(new_k_vdist) ! CALL array_release(new_k_pdist) CALL array_release(new_k_idist) ! Right CALL v_to_p_i_dist_o(new_k_vdist, & right_rdist%i%row_decimation, new_k_pdist, new_k_idist) CALL dbcsr_distribution_new(dense_right_dist, right_rdist%i%main%d%mp_env, & new_k_pdist, new_n_dist) CALL dbcsr_new_image_dist(dense_right_rdist, dense_right_dist, right_rdist) CALL dbcsr_distribution_release(dense_right_dist) CALL array_new(dense_right_rdist%i%col_image, & (/(1, i=1, array_size(new_n_dist))/), lb=1) dense_right_rdist%i%row_image = new_k_idist CALL array_hold(new_k_idist) dense_right_rdist%i%vrow_dist = new_k_vdist CALL array_hold(new_k_vdist) dense_right_rdist%i%vcol_dist = new_n_dist CALL array_hold(new_n_dist) ! CALL array_release(new_k_idist) CALL array_release(new_k_pdist) CALL array_release(new_m_dist) CALL array_release(new_n_dist) CALL array_release(new_k_vdist) ! CALL timestop(error_handle) END SUBROUTINE dbcsr_make_dists_dense SUBROUTINE dbcsr_reset_locals(matrix) !! Resets local rows, columns to the correct arrays and values. TYPE(dbcsr_type), INTENT(INOUT) :: matrix LOGICAL, PARAMETER :: dbg = .FALSE. TYPE(dbcsr_distribution_obj) :: dist ! --------------------------------------------------------------------------- dist = dbcsr_distribution(matrix) CALL dbcsr_release_locals(matrix) ! Rows IF (dbg) & WRITE (*, *) "reset local rows for ", TRIM(matrix%name), & matrix%nblkrows_local, "prow", matrix%index(dbcsr_slot_home_prow), & dbcsr_mp_myprow(dbcsr_distribution_mp(matrix%dist)) CALL dbcsr_get_local_rows(dist, matrix%local_rows, & matrix%index(dbcsr_slot_home_prow)) CALL array_hold(matrix%local_rows) IF (dbg) WRITE (*, *) "local rows", matrix%local_rows%low%data matrix%nblkrows_local = array_size(matrix%local_rows) CALL dbcsr_get_global_row_map(dist, matrix%global_rows) CALL array_hold(matrix%global_rows) matrix%has_local_rows = .TRUE. matrix%has_global_rows = .TRUE. ! Columns IF (dbg) & WRITE (*, *) "reset local cols for ", TRIM(matrix%name), & matrix%nblkcols_local, "pcol", matrix%index(dbcsr_slot_home_pcol), & dbcsr_mp_mypcol(dbcsr_distribution_mp(matrix%dist)) CALL dbcsr_get_local_cols(dist, matrix%local_cols, & matrix%index(dbcsr_slot_home_pcol)) CALL array_hold(matrix%local_cols) IF (dbg) WRITE (*, *) "local cols", matrix%local_cols%low%data matrix%nblkcols_local = array_size(matrix%local_cols) CALL dbcsr_get_global_col_map(dist, matrix%global_cols) CALL array_hold(matrix%global_cols) matrix%has_local_cols = .TRUE. matrix%has_global_cols = .TRUE. ! END SUBROUTINE dbcsr_reset_locals SUBROUTINE dbcsr_reset_vlocals(matrix, imgdist, do_rows) !! Resets local rows, columns to the correct arrays and values !! for images. TYPE(dbcsr_type), INTENT(INOUT) :: matrix TYPE(dbcsr_imagedistribution_obj), INTENT(INOUT) :: imgdist LOGICAL, INTENT(IN), OPTIONAL :: do_rows LOGICAL :: my_do_rows ! --------------------------------------------------------------------------- CALL dbcsr_release_locals(matrix) my_do_rows = .TRUE. IF (PRESENT(do_rows)) my_do_rows = do_rows ! Rows IF (.NOT. PRESENT(do_rows) .OR. my_do_rows) THEN CALL dbcsr_get_local_vrows(imgdist, matrix%local_rows, & matrix%index(dbcsr_slot_home_vprow)) ELSE matrix%local_rows = imgdist%i%main%d%local_rows END IF CALL array_hold(matrix%local_rows) matrix%has_local_rows = .TRUE. matrix%nblkrows_local = array_size(matrix%local_rows) matrix%index(dbcsr_slot_nblkrows_local) = array_size(matrix%local_rows) CALL dbcsr_get_global_vrow_map(imgdist, matrix%global_rows) CALL array_hold(matrix%global_rows) matrix%has_global_rows = .TRUE. ! Columns IF (.NOT. PRESENT(do_rows) .OR. .NOT. my_do_rows) THEN CALL dbcsr_get_local_vcols(imgdist, matrix%local_cols, & matrix%index(dbcsr_slot_home_vpcol)) ELSE matrix%local_cols = imgdist%i%main%d%local_cols END IF CALL array_hold(matrix%local_cols) matrix%has_local_cols = .TRUE. matrix%nblkcols_local = array_size(matrix%local_cols) matrix%index(dbcsr_slot_nblkcols_local) = array_size(matrix%local_cols) CALL dbcsr_get_global_vcol_map(imgdist, matrix%global_cols) CALL array_hold(matrix%global_cols) matrix%has_global_cols = .TRUE. END SUBROUTINE dbcsr_reset_vlocals SUBROUTINE dbcsr_get_local_vrows(imgdist, local_vrows, local_vprow) !! Determines mapping from local to global virtual process rows TYPE(dbcsr_imagedistribution_obj), INTENT(INOUT) :: imgdist !! image distribution TYPE(array_i1d_obj), INTENT(OUT) :: local_vrows !! local rows INTEGER, INTENT(IN) :: local_vprow !! the local virtual process row CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_local_vrows' INTEGER :: el, error_handle, nvprows, vprow INTEGER, ALLOCATABLE, DIMENSION(:) :: itmp, nle INTEGER, DIMENSION(:), POINTER :: vrow_dist IF (careful_mod) CALL timeset(routineN, error_handle) ! If the current local row mappings do not exist, create them. IF (.NOT. imgdist%i%has_other_vl_rows) THEN imgdist%i%has_other_vl_rows = .TRUE. nvprows = dbcsr_mp_nprows(dbcsr_distribution_mp(imgdist%i%main)) & *imgdist%i%row_decimation ALLOCATE (imgdist%i%other_vl_rows(0:nvprows - 1)) ALLOCATE (nle(0:nvprows - 1)) vrow_dist => array_data(imgdist%i%vrow_dist) ! Count the number of local elements per row. nle(:) = 0 DO el = 1, SIZE(vrow_dist) vprow = vrow_dist(el) nle(vprow) = nle(vprow) + 1 END DO DO vprow = 0, nvprows - 1 ALLOCATE (itmp(nle(vprow))) itmp = 0 CALL array_new(imgdist%i%other_vl_rows(vprow), & itmp, lb=1) DEALLOCATE (itmp) END DO DEALLOCATE (nle) CALL find_all_local_elements(imgdist%i%other_vl_rows, vrow_dist, nvprows) ELSE IF (careful_mod .AND. .NOT. ASSOCIATED(imgdist%i%other_vl_rows)) & DBCSR_ABORT("Local rows mapping does not exist.") END IF local_vrows = imgdist%i%other_vl_rows(local_vprow) IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_local_vrows SUBROUTINE dbcsr_get_local_vcols(imgdist, local_vcols, local_vpcol) !! Determines mapping from local to global virtual process columns TYPE(dbcsr_imagedistribution_obj), INTENT(INOUT) :: imgdist !! image distribution TYPE(array_i1d_obj), INTENT(OUT) :: local_vcols !! local columns INTEGER, INTENT(IN) :: local_vpcol !! the local virtual process column CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_local_vcols' INTEGER :: el, error_handle, nvpcols, vpcol INTEGER, ALLOCATABLE, DIMENSION(:) :: nle INTEGER, DIMENSION(:), POINTER :: itmp, vcol_dist IF (careful_mod) CALL timeset(routineN, error_handle) ! If the current local col mappings do not exist, create them. IF (.NOT. imgdist%i%has_other_vl_cols) THEN imgdist%i%has_other_vl_cols = .TRUE. nvpcols = dbcsr_mp_npcols(dbcsr_distribution_mp(imgdist%i%main)) & *imgdist%i%col_decimation ALLOCATE (imgdist%i%other_vl_cols(0:nvpcols - 1)) ALLOCATE (nle(0:nvpcols - 1)) vcol_dist => array_data(imgdist%i%vcol_dist) ! Count the number of local elements per col. nle(:) = 0 DO el = 1, SIZE(vcol_dist) vpcol = vcol_dist(el) nle(vpcol) = nle(vpcol) + 1 END DO DO vpcol = 0, nvpcols - 1 ALLOCATE (itmp(nle(vpcol))) itmp = 0 CALL array_new(imgdist%i%other_vl_cols(vpcol), & itmp, lb=1) DEALLOCATE (itmp) END DO DEALLOCATE (nle) CALL find_all_local_elements(imgdist%i%other_vl_cols, vcol_dist, nvpcols) ELSE IF (careful_mod .AND. .NOT. ASSOCIATED(imgdist%i%other_vl_cols)) & DBCSR_ABORT("Local cols mapping does not exist.") END IF local_vcols = imgdist%i%other_vl_cols(local_vpcol) IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_local_vcols SUBROUTINE image_calculator(image_dist, & prow, rowi, pcol, coli, vprow, vpcol, & myprow, mypcol, myrowi, mycoli, myvprow, myvpcol, & vprow_shift, vpcol_shift, & shifting) !! Transform between virtual process rows/columns and actual process rows/columns and images therein. !! !! Shifting !! (L)eft and (R)ight shifting are "shifts from", (l)eft and (r)ight !! are "shifts to". A caller (or the my* specifications) would use !! L/R to see which data he has (i.e., from where his data was !! shifted). To see where the caller's data goes to, use l/r. TYPE(dbcsr_imagedistribution_obj), INTENT(IN) :: image_dist INTEGER, INTENT(OUT), OPTIONAL :: prow, rowi, pcol, coli, vprow, vpcol INTEGER, INTENT(IN), OPTIONAL :: myprow, mypcol, myrowi, mycoli, myvprow, & myvpcol, vprow_shift, vpcol_shift CHARACTER, INTENT(IN), OPTIONAL :: shifting INTEGER :: col_mult, my_pcol, my_prow, ncol_images, & npcols, nprows, nrow_images, nvpcols, & nvprows, row_mult, vcol, vrow TYPE(dbcsr_mp_obj) :: mp ! --------------------------------------------------------------------------- IF (careful_mod .AND. .NOT. PRESENT(myvprow) .AND. .NOT. PRESENT(mycoli)) THEN CALL dbcsr_abort(__LOCATION__, & "Must specify either (process row and row image) or (virtual process row)") END IF IF (careful_mod .AND. .NOT. PRESENT(myvpcol) .AND. .NOT. PRESENT(mycoli)) THEN CALL dbcsr_abort(__LOCATION__, & "Must specify either (process col and col image) or (virtual process col)") END IF ! mp = image_dist%i%main%d%mp_env nprows = SIZE(mp%mp%pgrid, 1) npcols = SIZE(mp%mp%pgrid, 2) nrow_images = image_dist%i%row_decimation ncol_images = image_dist%i%col_decimation row_mult = image_dist%i%row_multiplicity col_mult = image_dist%i%col_multiplicity nvprows = nprows*nrow_images nvpcols = npcols*ncol_images ! IF (PRESENT(myprow)) THEN my_prow = myprow ELSE my_prow = mp%mp%myprow END IF IF (PRESENT(mypcol)) THEN my_pcol = mypcol ELSE my_pcol = mp%mp%mypcol END IF ! IF (.NOT. PRESENT(myvprow)) THEN vrow = my_prow*nrow_images + myrowi - 1 ELSE vrow = myvprow END IF IF (.NOT. PRESENT(myvpcol)) THEN vcol = my_pcol*ncol_images + mycoli - 1 ELSE vcol = myvpcol END IF ! IF (PRESENT(vprow_shift)) vrow = vrow + vprow_shift IF (PRESENT(vpcol_shift)) vcol = vcol + vpcol_shift IF (PRESENT(shifting)) THEN SELECT CASE (shifting) CASE ('R') vrow = vrow + my_pcol*row_mult CASE ('L') vcol = vcol + my_prow*col_mult CASE ('r') vrow = vrow - my_pcol*row_mult CASE ('l') vcol = vcol - my_prow*col_mult END SELECT END IF vrow = MODULO(vrow, nvprows) vcol = MODULO(vcol, nvpcols) IF (PRESENT(prow)) prow = vrow/nrow_images IF (PRESENT(rowi)) rowi = MODULO(vrow, nrow_images) + 1 IF (PRESENT(pcol)) pcol = vcol/ncol_images IF (PRESENT(coli)) coli = MODULO(vcol, ncol_images) + 1 IF (PRESENT(vprow)) vprow = vrow IF (PRESENT(vpcol)) vpcol = vcol END SUBROUTINE image_calculator SUBROUTINE make_sizes_dense(old_sizes, mapping, nel_new, new_sizes) !! Matches row/block sizes and offsets to a given distribution !! @note Used for making matrices dense/undense TYPE(array_i1d_obj), INTENT(IN) :: old_sizes, mapping INTEGER, INTENT(IN) :: nel_new TYPE(array_i1d_obj), INTENT(OUT) :: new_sizes INTEGER :: el, nel_old INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: map, new_s, old_s ! --------------------------------------------------------------------------- map => array_data(mapping) old_s => array_data(old_sizes) nel_old = array_size(old_sizes) ALLOCATE (new_s(nel_new)) new_s(:) = 0 DO el = 1, nel_old new_s(map(el)) = new_s(map(el)) + old_s(el) END DO CALL array_new(new_sizes, new_s, gift=.TRUE.) END SUBROUTINE make_sizes_dense SUBROUTINE dbcsr_make_1dist_dense(nbins, old_dist, dense_dist, dist_map, nsubdist, subdist) !! Makes a 1-D distribution dense. INTEGER, INTENT(IN) :: nbins !! Number of bins in the main distribution TYPE(array_i1d_obj), INTENT(IN) :: old_dist !! Current distribution TYPE(array_i1d_obj), INTENT(OUT) :: dense_dist, dist_map !! Dense distribution !! Map from current to dense distribution INTEGER, INTENT(IN) :: nsubdist !! Number of bins in the subdistribution INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: subdist !! Subdistribution INTEGER :: b, i, n_new_bins INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: dense, map, old_d ! --------------------------------------------------------------------------- IF (nsubdist .EQ. 0) THEN n_new_bins = nbins ELSE n_new_bins = nbins*nsubdist END IF old_d => array_data(old_dist) ALLOCATE (dense(n_new_bins)) ALLOCATE (map(array_size(old_dist))) ! IF (nsubdist .EQ. 0) THEN dense(:) = (/(b, b=0, n_new_bins - 1)/) map(:) = old_d(:) + 1 ELSE DO i = 1, nbins dense((i - 1)*nsubdist + 1:(i)*nsubdist) = i - 1 END DO map(:) = old_d(:)*nsubdist + subdist(:) + 1 END IF ! CALL array_new(dense_dist, dense, gift=.TRUE.) CALL array_new(dist_map, map, gift=.TRUE.) END SUBROUTINE dbcsr_make_1dist_dense pure SUBROUTINE v_to_p_i_dist(nel, vdist, nim, pdist, idist) !! Converts virtual 1-D distribution to process and image INTEGER, INTENT(in) :: nel INTEGER, DIMENSION(1:nel), INTENT(in) :: vdist INTEGER, INTENT(in) :: nim INTEGER, DIMENSION(1:nel), INTENT(out) :: pdist, idist INTEGER :: i DO i = 1, nel pdist(i) = vdist(i)/nim idist(i) = MOD(vdist(i), nim) + 1 END DO END SUBROUTINE v_to_p_i_dist SUBROUTINE v_to_p_i_dist_o(vdist, nim, pdist, idist) TYPE(array_i1d_obj), INTENT(in) :: vdist INTEGER, INTENT(in) :: nim TYPE(array_i1d_obj), INTENT(out) :: pdist, idist INTEGER :: nel INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: id, pd, vd nel = array_size(vdist) vd => array_data(vdist) ALLOCATE (pd(nel), id(nel)) CALL v_to_p_i_dist(nel, vd, nim, pd, id) CALL array_new(pdist, pd, gift=.TRUE.) CALL array_new(idist, id, gift=.TRUE.) END SUBROUTINE v_to_p_i_dist_o SUBROUTINE dbcsr_get_global_row_map(dist, row_map) !! Determines mapping from global to local rows TYPE(dbcsr_distribution_obj), INTENT(INOUT) :: dist !! mapping for this distribution TYPE(array_i1d_obj), INTENT(OUT) :: row_map !! mapping to local rows CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_global_row_map' INTEGER :: error_handle, nprows INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: rmap, row_dist CALL timeset(routineN, error_handle) ! If the current local row mappings do not exist, create them. IF (.NOT. dist%d%has_global_row_map) THEN row_dist => dbcsr_distribution_row_dist(dist) ALLOCATE (rmap(SIZE(row_dist))) nprows = dbcsr_mp_nprows(dbcsr_distribution_mp(dist)) CALL map_all_local_elements(rmap, row_dist, nprows) CALL array_new(dist%d%global_row_map, rmap, gift=.TRUE.) dist%d%has_global_row_map = .TRUE. ELSE IF (careful_mod .AND. .NOT. array_exists(dist%d%global_row_map)) & DBCSR_ABORT("Row map does not exist.") END IF row_map = dist%d%global_row_map CALL timestop(error_handle) END SUBROUTINE dbcsr_get_global_row_map SUBROUTINE dbcsr_get_global_col_map(dist, col_map) !! Determines mapping from global to local columns TYPE(dbcsr_distribution_obj), INTENT(INOUT) :: dist !! mapping for this distribution TYPE(array_i1d_obj), INTENT(OUT) :: col_map !! mapping to local columns CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_global_col_map' INTEGER :: error_handle, npcols INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: cmap, col_dist CALL timeset(routineN, error_handle) ! If the current local col mappings do not exist, create them. IF (.NOT. dist%d%has_global_col_map) THEN col_dist => dbcsr_distribution_col_dist(dist) ALLOCATE (cmap(SIZE(col_dist))) npcols = dbcsr_mp_npcols(dbcsr_distribution_mp(dist)) CALL map_all_local_elements(cmap, col_dist, npcols) CALL array_new(dist%d%global_col_map, cmap, gift=.TRUE.) dist%d%has_global_col_map = .TRUE. ELSE IF (careful_mod .AND. .NOT. array_exists(dist%d%global_col_map)) & DBCSR_ABORT("Column map does not exist.") END IF col_map = dist%d%global_col_map CALL timestop(error_handle) END SUBROUTINE dbcsr_get_global_col_map SUBROUTINE dbcsr_get_global_vrow_map(imgdist, vrow_map) !! Determines mapping from global to virtual local rows TYPE(dbcsr_imagedistribution_obj), INTENT(INOUT) :: imgdist !! mapping for this image distribution TYPE(array_i1d_obj), INTENT(OUT) :: vrow_map !! mapping to local rows CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_global_vrow_map' INTEGER :: error_handle, nvprows INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: rmap, vrow_dist IF (careful_mod) CALL timeset(routineN, error_handle) ! If the current local row mappings do not exist, create them. IF (.NOT. imgdist%i%has_global_vrow_map) THEN vrow_dist => array_data(imgdist%i%vrow_dist) ALLOCATE (rmap(SIZE(vrow_dist))) nvprows = dbcsr_mp_nprows(dbcsr_distribution_mp(imgdist%i%main)) & *imgdist%i%row_decimation CALL map_all_local_elements(rmap, vrow_dist, nvprows) CALL array_new(imgdist%i%global_vrow_map, rmap, gift=.TRUE.) imgdist%i%has_global_vrow_map = .TRUE. ELSE IF (careful_mod .AND. .NOT. array_exists(imgdist%i%global_vrow_map)) & DBCSR_ABORT("Row map does not exist.") END IF vrow_map = imgdist%i%global_vrow_map IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_global_vrow_map SUBROUTINE dbcsr_get_global_vcol_map(imgdist, vcol_map) !! Determines mapping from global to virtual local columns TYPE(dbcsr_imagedistribution_obj), INTENT(INOUT) :: imgdist !! mapping for this image distribution TYPE(array_i1d_obj), INTENT(OUT) :: vcol_map !! mapping to local columns CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_global_vcol_map' INTEGER :: error_handle, nvpcols INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: rmap, vcol_dist IF (careful_mod) CALL timeset(routineN, error_handle) ! If the current local col mappings do not exist, create them. IF (.NOT. imgdist%i%has_global_vcol_map) THEN vcol_dist => array_data(imgdist%i%vcol_dist) ALLOCATE (rmap(SIZE(vcol_dist))) nvpcols = dbcsr_mp_npcols(dbcsr_distribution_mp(imgdist%i%main)) & *imgdist%i%col_decimation CALL map_all_local_elements(rmap, vcol_dist, nvpcols) CALL array_new(imgdist%i%global_vcol_map, rmap, gift=.TRUE.) imgdist%i%has_global_vcol_map = .TRUE. ELSE IF (careful_mod .AND. .NOT. array_exists(imgdist%i%global_vcol_map)) & DBCSR_ABORT("Col map does not exist.") END IF vcol_map = imgdist%i%global_vcol_map IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_global_vcol_map PURE SUBROUTINE map_all_local_elements(global_elements, & bin_distribution, nbins) !! Points to local virtual elements. !! All elements are mapped at once. Therefore an entry in the !! resulting array can be used as a lookup index for any of the local !! element arrays. The distribution itself tells into which array to !! look. INTEGER, DIMENSION(:), INTENT(OUT) :: global_elements !! enumerated local elements INTEGER, DIMENSION(:), INTENT(IN) :: bin_distribution !! distribution of elements to bins INTEGER, INTENT(IN) :: nbins !! number of bins INTEGER :: bin, el INTEGER, DIMENSION(0:nbins - 1) :: nlve nlve(:) = 0 DO el = 1, SIZE(bin_distribution) bin = bin_distribution(el) nlve(bin) = nlve(bin) + 1 global_elements(el) = nlve(bin) END DO END SUBROUTINE map_all_local_elements SUBROUTINE reimage_distribution(images, my_bins, & nbins, nimages) !! Makes new distribution with decimation and multiplicity !! Multiplicity is being ignored, maybe this is a bug !! !! Definition of multiplicity and nimages !! Multiplicity and decimation (number of images) are used to !! match process grid coordinates on non-square process !! grids. Given source_nbins and target_nbins, their relation is !! source_nbins * target_multiplicity !! = target_nbins * target_nimages. !! It is best when both multiplicity and nimages are small. To !! get these two factors, then, one can use the following formulas: !! nimages = lcm(source_nbins, target_nbins) / target_nbins !! multiplicity = target_nbins / gcd(source_nbins, target_nbins) !! from the target's point of view (nimages = target_nimages). !! !! Mapping !! The new distribution comprises of real bins and images within !! bins. These can be view as target_nbins*nimages virtual !! columns. These same virtual columns are also !! source_nbins*multiplicity in number. Therefore these virtual !! columns are mapped from source_nbins*multiplicity onto !! target_bins*nimages (each target bin has nimages images): !! Source 4: |1 2 3|4 5 6|7 8 9|A B C| (4*3) !! Target 6: |1 2|3 4|5 6|7 8|9 A|B C| (6*2) !! multiplicity=3, nimages=2, 12 virtual columns (1-C). !! Source bin elements are evenly mapped into one of multiplicity !! virtual columns. Other (non-even, block-size aware) mappings !! could be better. INTEGER, DIMENSION(:), INTENT(OUT) :: images !! new image distribution INTEGER, DIMENSION(:), INTENT(IN) :: my_bins !! Basis for the new images INTEGER, INTENT(IN) :: nbins, nimages !! number of bins in the new real distribution !! number of images in the new distribution INTEGER :: bin, i INTEGER, ALLOCATABLE, DIMENSION(:) :: bin_multiplier ! --------------------------------------------------------------------------- ALLOCATE (bin_multiplier(0:nbins - 1)) bin_multiplier(:) = 0 DO i = 1, SIZE(my_bins) bin = my_bins(i) images(i) = 1 + bin_multiplier(bin) bin_multiplier(bin) = bin_multiplier(bin) + 1 IF (bin_multiplier(bin) .GE. nimages) THEN bin_multiplier(bin) = 0 END IF END DO END SUBROUTINE reimage_distribution PURE SUBROUTINE make_vdistribution(nelements, vbins, bins, decimation, images) !! Makes new virtual distribution of rows/columns. INTEGER, INTENT(IN) :: nelements !! number of elements INTEGER, DIMENSION(nelements), INTENT(OUT) :: vbins !! virtual bins INTEGER, DIMENSION(nelements), INTENT(IN) :: bins !! bins to which elements belong INTEGER, INTENT(IN) :: decimation !! matching between bins INTEGER, DIMENSION(nelements), INTENT(IN) :: images !! images to which element belong INTEGER :: el ! --------------------------------------------------------------------------- DO el = 1, nelements vbins(el) = bins(el)*decimation + images(el) - 1 END DO END SUBROUTINE make_vdistribution SUBROUTINE rebin_imaged_distribution(new_bins, images, & source_bins, source_images, nbins, multiplicity, nimages) !! Makes new distribution with multiplicity !! !! Definition of multiplicity and nimages !! Multiplicity and number of images are used to match process !! grid coordinates on non-square process grids. Given !! source_nbins and target_nbins, their relation is !! source_nbins * multiplicity = target_nbins * nimages. !! It is best when both multiplicity and nimages are small. To !! get these two factors, then, one can use the following formulas: !! nimages = lcm(source_nbins, target_nbins) / target_nbins !! multiplicity = target_nbins / gcd(source_nbins, target_nbins) !! !! Mapping !! The new distribution comprises of real bins and images within !! bins. These can be view as target_nbins*nimages virtual !! columns. These same virtual columns are also !! source_nbins*multiplicity in number. Therefore these virtual !! columns are mapped from source_nbins*multiplicity onto !! target_bins*nimages (each target bin has nimages images): !! Source 4: |1 2 3|4 5 6|7 8 9|A B C| (4*3) !! Target 6: |1 2|3 4|5 6|7 8|9 A|B C| (6*2) !! multiplicity=3, nimages=2, 12 virtual columns (1-C). !! Source bin elements are evenly mapped into one of multiplicity !! virtual columns. Other (non-even, block-size aware) mappings !! could be better. INTEGER, DIMENSION(:), INTENT(OUT) :: new_bins, images !! new real distribution !! new image distribution INTEGER, DIMENSION(:), INTENT(IN) :: source_bins, source_images !! Basis for the new distribution and images !! Basis for the new distribution and images INTEGER, INTENT(IN) :: nbins, multiplicity, nimages !! number of bins in the new real distribution !! multiplicity !! number of images in the new distribution INTEGER :: i, virtual_bin ! --------------------------------------------------------------------------- DO i = 1, SIZE(new_bins) IF (i .LE. SIZE(source_bins)) THEN virtual_bin = source_bins(i)*multiplicity + source_images(i) - 1 ELSE ! Fill remainder with a cyclic distribution virtual_bin = MOD(i, nbins*nimages) END IF new_bins(i) = virtual_bin/nimages images(i) = 1 + MOD(virtual_bin, nimages) IF (new_bins(i) .GE. nbins) & DBCSR_ABORT("Wrong bin calculation") IF (images(i) .GT. nimages) & DBCSR_ABORT("Wrong image calculation") END DO END SUBROUTINE rebin_imaged_distribution END MODULE dbcsr_mm_dist_operations