# 1 "/__w/dbcsr/dbcsr/src/block/dbcsr_block_access.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_block_access !! DBCSR block access USE dbcsr_array_types, ONLY: array_data USE dbcsr_btree, ONLY: btree_add, & btree_data_cp2d, & btree_data_dp2d, & btree_data_sp2d, & btree_data_zp2d, & btree_find USE dbcsr_block_operations, ONLY: dbcsr_data_clear, & dbcsr_data_set USE dbcsr_config, ONLY: default_resize_factor USE dbcsr_data_methods, ONLY: dbcsr_data_clear_pointer, & dbcsr_data_ensure_size, & dbcsr_data_get_size_referenced, & dbcsr_data_set_pointer, & dbcsr_get_data, & dbcsr_get_data_p, & dbcsr_get_data_p_s, & dbcsr_get_data_p_d, & dbcsr_get_data_p_c USE dbcsr_dist_methods, ONLY: dbcsr_distribution_local_cols, & dbcsr_distribution_local_rows, & dbcsr_distribution_mp USE dbcsr_dist_operations, ONLY: dbcsr_get_block_index, & dbcsr_get_stored_block_info, & dbcsr_get_stored_coordinates USE dbcsr_index_operations, ONLY: dbcsr_addto_index_array, & dbcsr_clearfrom_index_array, & dbcsr_expand_row_index, & dbcsr_make_dbcsr_index, & dbcsr_sort_indices, & merge_index_arrays USE dbcsr_methods, ONLY: & dbcsr_blk_column_size, dbcsr_blk_row_size, dbcsr_distribution, dbcsr_get_data_type, & dbcsr_get_num_blocks, dbcsr_mutable_instantiated, dbcsr_mutable_new, dbcsr_nblkrows_total, & dbcsr_use_mutable, dbcsr_wm_use_mutable USE dbcsr_mp_methods, ONLY: dbcsr_mp_mynode USE dbcsr_ptr_util, ONLY: pointer_rank_remap2, & pointer_view USE dbcsr_toollib, ONLY: make_coordinate_tuple, & swap USE dbcsr_types, ONLY: & dbcsr_data_obj, dbcsr_scalar_type, dbcsr_slot_blk_p, dbcsr_slot_col_i, dbcsr_slot_nblks, & dbcsr_slot_nze, dbcsr_type, dbcsr_type_complex_4, dbcsr_type_complex_4_2d, & dbcsr_type_complex_8, dbcsr_type_complex_8_2d, dbcsr_type_real_4, dbcsr_type_real_4_2d, & dbcsr_type_real_8, dbcsr_type_real_8_2d USE dbcsr_work_operations, ONLY: add_work_coordinate, & dbcsr_work_create USE dbcsr_kinds, ONLY: dp, & int_8, & real_4, & real_8 #include "base/dbcsr_base_uses.f90" !$ USE OMP_LIB, ONLY: omp_get_thread_num, omp_get_num_threads IMPLICIT NONE PRIVATE CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_block_access' PUBLIC :: dbcsr_get_block_p, & dbcsr_put_block, dbcsr_remove_block PUBLIC :: dbcsr_reserve_block2d, & dbcsr_reserve_blocks, dbcsr_reserve_all_blocks, dbcsr_reserve_diag_blocks INTERFACE dbcsr_get_block_p MODULE PROCEDURE dbcsr_get_block_p_d, dbcsr_get_block_p_s, & dbcsr_get_block_p_z, dbcsr_get_block_p_c MODULE PROCEDURE dbcsr_get_2d_block_p_d, dbcsr_get_2d_block_p_s, & dbcsr_get_2d_block_p_z, dbcsr_get_2d_block_p_c MODULE PROCEDURE dbcsr_get_block_p_area END INTERFACE INTERFACE dbcsr_put_block MODULE PROCEDURE dbcsr_put_block_area MODULE PROCEDURE dbcsr_put_block_d, dbcsr_put_block_s, & dbcsr_put_block_z, dbcsr_put_block_c MODULE PROCEDURE dbcsr_put_block2d_d, dbcsr_put_block2d_s, & dbcsr_put_block2d_z, dbcsr_put_block2d_c END INTERFACE INTERFACE dbcsr_reserve_block2d MODULE PROCEDURE dbcsr_reserve_block2d_s, dbcsr_reserve_block2d_d, & dbcsr_reserve_block2d_c, dbcsr_reserve_block2d_z END INTERFACE INTERFACE dbcsr_set_block_pointer MODULE PROCEDURE dbcsr_set_block_pointer_any MODULE PROCEDURE dbcsr_set_block_pointer_2d_s, & dbcsr_set_block_pointer_2d_d, & dbcsr_set_block_pointer_2d_c, & dbcsr_set_block_pointer_2d_z END INTERFACE LOGICAL, PARAMETER :: careful_mod = .FALSE. LOGICAL, PARAMETER :: debug_mod = .FALSE. INTEGER, PARAMETER, PRIVATE :: rpslot_owner = 1 INTEGER, PARAMETER, PRIVATE :: rpslot_addblks = 2 INTEGER, PARAMETER, PRIVATE :: rpslot_addoffset = 3 INTEGER, PARAMETER, PRIVATE :: rpslot_oldblks = 4 INTEGER, PARAMETER, PRIVATE :: rpslot_oldoffset = 5 INTEGER, PARAMETER, PRIVATE :: rpslot_totaloffset = 6 INTEGER, PARAMETER, PRIVATE :: rpnslots = 6 LOGICAL, PARAMETER, PRIVATE :: detailed_timing = .FALSE. TYPE block_parameters LOGICAL :: tr = .FALSE. INTEGER :: logical_rows = -1, logical_cols = -1 INTEGER :: offset = -1, nze = -1 END TYPE block_parameters TYPE dgemm_join INTEGER :: p_a = -1, p_b = -1, p_c = -1 INTEGER :: last_k = -1, last_n = -1 TYPE(dbcsr_scalar_type) :: alpha = dbcsr_scalar_type(), beta = dbcsr_scalar_type() END TYPE dgemm_join CONTAINS SUBROUTINE dbcsr_remove_block(matrix, row, col, block_nze, block_number) !! Marks a block for removal from a DBCSR matrix. Handles !! symmetric matrices. TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col, block_nze !! row of block to remove !! column of block to remove INTEGER, INTENT(IN), OPTIONAL :: block_number !! the block number, if it is known CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_remove_block' INTEGER :: b, c, error_handle, r LOGICAL :: found, tr ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handle) IF (PRESENT(block_number)) THEN b = block_number IF (block_number .GT. matrix%nblks) & DBCSR_ABORT("Block number too big.") found = .TRUE. ELSE CALL dbcsr_get_block_index(matrix, row, col, r, c, tr, found, b) END IF b = ABS(b) IF (found .AND. b .GT. 0) THEN ! Mark the block for deletion. matrix%blk_p(b) = 0 matrix%valid = .FALSE. ! update nze accordingly matrix%nze = matrix%nze - block_nze IF (debug_mod) THEN IF (matrix%nze < 0) DBCSR_ABORT("nze < 0!") END IF ELSE IF (debug_mod) THEN IF (b .EQ. 0) & DBCSR_WARN("Block does not exist or is already deleted.") END IF END IF IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_remove_block SUBROUTINE dbcsr_get_block_p_area(matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a block from a dbcsr matrix as a data area !! !! Data area !! The pointer encapsulated in the data area points to data stored in the !! matrix. It must be 2-dimensional. TYPE(dbcsr_type), INTENT(IN) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column TYPE(dbcsr_data_obj), INTENT(INOUT) :: block !! the block to get LOGICAL, INTENT(OUT) :: tr, found !! whether the data is transposed !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_block_p_area' INTEGER :: blk, csize, error_handle, iw, offset, & rsize, stored_col, stored_row LOGICAL :: stored_tr TYPE(btree_data_cp2d) :: data_block_c TYPE(btree_data_dp2d) :: data_block_d TYPE(btree_data_sp2d) :: data_block_s TYPE(btree_data_zp2d) :: data_block_z ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handle) CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize CALL dbcsr_data_clear_pointer(block) IF (found) THEN CALL dbcsr_set_block_pointer(matrix, block, rsize, csize, stored_tr, offset) ELSEIF (ASSOCIATED(matrix%wms)) THEN iw = 1 !$ iw = omp_get_thread_num() + 1 IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN SELECT CASE (block%d%data_type) CASE (dbcsr_type_real_4_2d) CALL btree_find( & matrix%wms(iw)%mutable%m%btree_s, & make_coordinate_tuple(stored_row, stored_col), & data_block_s, found) IF (found) THEN CALL dbcsr_data_set_pointer(block, data_block_s%p) END IF CASE (dbcsr_type_real_8_2d) CALL btree_find( & matrix%wms(iw)%mutable%m%btree_d, & make_coordinate_tuple(stored_row, stored_col), & data_block_d, found) IF (found) THEN CALL dbcsr_data_set_pointer(block, data_block_d%p) END IF CASE (dbcsr_type_complex_4_2d) CALL btree_find( & matrix%wms(iw)%mutable%m%btree_c, & make_coordinate_tuple(stored_row, stored_col), & data_block_c, found) IF (found) THEN CALL dbcsr_data_set_pointer(block, data_block_c%p) END IF CASE (dbcsr_type_complex_8_2d) CALL btree_find( & matrix%wms(iw)%mutable%m%btree_z, & make_coordinate_tuple(stored_row, stored_col), & data_block_z, found) IF (found) THEN CALL dbcsr_data_set_pointer(block, data_block_z%p) END IF CASE default DBCSR_ABORT("Only 2-D data for block pointers!") END SELECT END IF END IF IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_block_p_area SUBROUTINE dbcsr_put_block_area(matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! We allow : !! matrix(dp) [+]= [scale(dp)] * block(dp) !! matrix(dp) [+]= [scale(dp)] * block(sp) !! matrix(sp) [+]= [scale(dp)] * block(sp) TYPE(dbcsr_type), INTENT(INOUT) :: matrix INTEGER, INTENT(IN) :: row, col TYPE(dbcsr_data_obj) :: block INTEGER, DIMENSION(2), INTENT(INOUT), OPTIONAL :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop TYPE(dbcsr_scalar_type), INTENT(IN), OPTIONAL :: scale CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_put_block_area' INTEGER :: data_type_m, error_handle LOGICAL :: do_scale ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handle) data_type_m = dbcsr_get_data_type(matrix) do_scale = PRESENT(scale) IF (do_scale) THEN !IF(data_type_m /= scale%data_type) & ! DBCSR_ABORT("Incompatible data types matrix="//data_type_m//" scale="//scale%data_type) END IF IF (.NOT. ASSOCIATED(block%d)) & DBCSR_ABORT("Can only add valid data block!") SELECT CASE (block%d%data_type) CASE (dbcsr_type_real_4) IF (do_scale) THEN IF (data_type_m .EQ. dbcsr_type_real_4) THEN CALL dbcsr_put_block(matrix, row, col, dbcsr_get_data_p_s(block), lb_row_col, transposed, & summation, flop, scale=scale%r_sp) ELSEIF (data_type_m .EQ. dbcsr_type_real_8) THEN CALL dbcsr_put_block(matrix, row, col, & REAL(dbcsr_get_data_p_s(block), real_8), lb_row_col, transposed, & summation, flop, scale=REAL(scale%r_sp, real_8)) END IF ELSE IF (data_type_m .EQ. dbcsr_type_real_4) THEN CALL dbcsr_put_block(matrix, row, col, dbcsr_get_data_p_s(block), lb_row_col, transposed, & summation, flop) ELSEIF (data_type_m .EQ. dbcsr_type_real_8) THEN CALL dbcsr_put_block(matrix, row, col, & REAL(dbcsr_get_data_p_s(block), real_8), lb_row_col, transposed, & summation, flop) END IF END IF CASE (dbcsr_type_real_8) IF (do_scale) THEN CALL dbcsr_put_block(matrix, row, col, dbcsr_get_data_p_d(block), lb_row_col, transposed, & summation, flop, scale=scale%r_dp) ELSE CALL dbcsr_put_block(matrix, row, col, dbcsr_get_data_p_d(block), lb_row_col, transposed, & summation, flop) END IF CASE (dbcsr_type_complex_4) IF (do_scale) THEN CALL dbcsr_put_block(matrix, row, col, dbcsr_get_data_p_c(block), lb_row_col, transposed, & summation, flop, scale=scale%c_sp) ELSE CALL dbcsr_put_block(matrix, row, col, dbcsr_get_data_p_c(block), lb_row_col, transposed, & summation, flop) END IF CASE (dbcsr_type_complex_8) IF (do_scale) THEN CALL dbcsr_put_block(matrix, row, col, block%d%c_dp, lb_row_col, transposed, & summation, flop, scale=scale%c_dp) ELSE CALL dbcsr_put_block(matrix, row, col, block%d%c_dp, lb_row_col, transposed, & summation, flop) END IF CASE (dbcsr_type_real_4_2d) IF (do_scale) THEN CALL dbcsr_put_block(matrix, row, col, block%d%r2_sp, lb_row_col, transposed, & summation, flop, scale=scale%r_sp) ELSE CALL dbcsr_put_block(matrix, row, col, block%d%r2_sp, lb_row_col, transposed, & summation, flop) END IF CASE (dbcsr_type_real_8_2d) IF (do_scale) THEN CALL dbcsr_put_block(matrix, row, col, block%d%r2_dp, lb_row_col, transposed, & summation, flop, scale=scale%r_dp) ELSE CALL dbcsr_put_block(matrix, row, col, block%d%r2_dp, lb_row_col, transposed, & summation, flop) END IF CASE (dbcsr_type_complex_4_2d) IF (do_scale) THEN CALL dbcsr_put_block(matrix, row, col, block%d%c2_sp, lb_row_col, transposed, & summation, flop, scale=scale%c_sp) ELSE CALL dbcsr_put_block(matrix, row, col, block%d%c2_sp, lb_row_col, transposed, & summation, flop) END IF CASE (dbcsr_type_complex_8_2d) IF (do_scale) THEN CALL dbcsr_put_block(matrix, row, col, block%d%c2_dp, lb_row_col, transposed, & summation, flop, scale=scale%c_dp) ELSE CALL dbcsr_put_block(matrix, row, col, block%d%c2_dp, lb_row_col, transposed, & summation, flop) END IF CASE default DBCSR_ABORT("Invalid data type") END SELECT IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_put_block_area SUBROUTINE dbcsr_reserve_all_blocks(matrix) !! Inserts all blocks of a dbcsr matrix to make it a full matrix. !! Thus obviously not linear scaling. TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! Matrix into which blocks should be added. CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_reserve_all_blocks' INTEGER :: blk_count, col, col_local, col_s, & error_handle, myrank, rank, row, & row_local, row_s INTEGER, ALLOCATABLE, DIMENSION(:) :: columns, rows INTEGER, DIMENSION(:), POINTER :: local_cols, local_rows LOGICAL :: tr CALL timeset(routineN, error_handle) myrank = dbcsr_mp_mynode(dbcsr_distribution_mp(dbcsr_distribution(matrix))) local_rows => dbcsr_distribution_local_rows(dbcsr_distribution(matrix)) local_cols => dbcsr_distribution_local_cols(dbcsr_distribution(matrix)) blk_count = 0 ! should be possible to loop only over the local blockrows/blockcols DO row_local = 1, SIZE(local_rows) DO col_local = 1, SIZE(local_cols) tr = .FALSE. row = local_rows(row_local) col = local_cols(col_local) row_s = row; col_s = col CALL dbcsr_get_stored_coordinates(matrix, row_s, col_s, rank) ! is that the correct condition for symmetric matrices ? IF (rank .EQ. myrank .AND. row_s .EQ. row .AND. col_s .EQ. col) blk_count = blk_count + 1 END DO END DO ALLOCATE (rows(blk_count), columns(blk_count)) blk_count = 0 DO row_local = 1, SIZE(local_rows) DO col_local = 1, SIZE(local_cols) tr = .FALSE. row = local_rows(row_local) col = local_cols(col_local) row_s = row; col_s = col CALL dbcsr_get_stored_coordinates(matrix, row_s, col_s, rank) IF (rank .EQ. myrank .AND. row_s .EQ. row .AND. col_s .EQ. col) THEN blk_count = blk_count + 1 rows(blk_count) = row columns(blk_count) = col END IF END DO END DO CALL dbcsr_reserve_blocks(matrix, rows, columns) CALL timestop(error_handle) END SUBROUTINE dbcsr_reserve_all_blocks SUBROUTINE dbcsr_reserve_diag_blocks(matrix) !! Inserts diagonal blocks of a dbcsr matrix to make it a matrix with at least all diagonal blocks present TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! Matrix into which blocks should be added. INTEGER :: blk_count, col, col_s, myrank, rank, & row, row_s INTEGER, ALLOCATABLE, DIMENSION(:) :: columns, rows LOGICAL :: tr myrank = dbcsr_mp_mynode(dbcsr_distribution_mp(dbcsr_distribution(matrix))) blk_count = 0 ! should be possible to loop only over the local blockrows/blockcols DO row = 1, dbcsr_nblkrows_total(matrix) col = row tr = .FALSE. row_s = row; col_s = col CALL dbcsr_get_stored_coordinates(matrix, row_s, col_s, rank) IF (rank .EQ. myrank .AND. row_s .EQ. row .AND. col_s .EQ. col) blk_count = blk_count + 1 END DO ALLOCATE (rows(blk_count), columns(blk_count)) blk_count = 0 DO row = 1, dbcsr_nblkrows_total(matrix) col = row tr = .FALSE. row_s = row; col_s = col CALL dbcsr_get_stored_coordinates(matrix, row_s, col_s, rank) IF (rank .EQ. myrank .AND. row_s .EQ. row .AND. col_s .EQ. col) THEN blk_count = blk_count + 1 rows(blk_count) = row columns(blk_count) = col END IF END DO CALL dbcsr_reserve_blocks(matrix, rows, columns) END SUBROUTINE dbcsr_reserve_diag_blocks SUBROUTINE dbcsr_reserve_blocks(matrix, rows, columns, blk_pointers) !! Inserts block reservations into a matrix, avoiding the work matrix. !! !! Data !! No data can be specified; instead, space is reserved and zeroed. To !! add data, call dbcsr_put_block afterwards. !! !! Reserving existing blocks !! Duplicates are not added, but allocations may be greater than !! the minimum necessary. !! !! blk_pointers !! When blk_pointers is passed, the newly added blocks use these pointers. !! No data is cleared in this case TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! Matrix into which blocks should be added. INTEGER, DIMENSION(:), INTENT(IN) :: rows, columns !! Rows of the blocks to add !! Columns of the blocks to add INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: blk_pointers !! block pointers to use for new blocks CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_reserve_blocks' INTEGER :: blk, blk_p, data_size_new, data_size_old, handle, nblkrows, nblks_actual_added, & nblks_added, nblks_new, nblks_old, new_data_sizes, nze INTEGER, ALLOCATABLE, DIMENSION(:) :: add_blkp, add_cols, add_rows, & added_sizes, new_blk_p, new_col_i, & new_row_i, old_row_i INTEGER, ALLOCATABLE, DIMENSION(:, :) :: added_blk_info ! --------------------------------------------------------------------------- CALL timeset(routineN, handle) IF (SIZE(rows) /= SIZE(columns)) & DBCSR_ABORT("Size of rows and columns array must match.") IF (PRESENT(blk_pointers)) THEN IF (SIZE(rows) /= SIZE(blk_pointers)) & DBCSR_ABORT("Size of rows and block pointecs arrays must match.") data_size_old = 0 ELSE ! Get current data size data_size_old = dbcsr_data_get_size_referenced(matrix%data_area) END IF ! Ensures that the rows and columns are sorted. nblks_added = SIZE(rows) ALLOCATE (add_rows(nblks_added)) add_rows(:) = rows(:) ALLOCATE (add_cols(nblks_added)) add_cols(:) = columns(:) IF (PRESENT(blk_pointers)) THEN ALLOCATE (add_blkp(nblks_added)) add_blkp(:) = blk_pointers(:) CALL dbcsr_sort_indices(nblks_added, add_rows, add_cols, & blk_p=add_blkp) ELSE CALL dbcsr_sort_indices(nblks_added, add_rows, add_cols) END IF nblks_old = dbcsr_get_num_blocks(matrix) nblkrows = dbcsr_nblkrows_total(matrix) IF (SIZE(rows) .GT. 0 .AND. nblkrows .LE. 0) & DBCSR_ABORT("Can not add blocks to matrix with no rows.") ! Adjust the index. ! Get the old row indices ALLOCATE (old_row_i(nblks_old)) CALL dbcsr_expand_row_index(matrix%row_p, old_row_i, & nblkrows, nblks_old) ! Calculate new block pointers. Possibly high estimates. new_data_sizes = 0 blk_p = data_size_old + 1 ! New blocks start at the end of the old ALLOCATE (added_blk_info(3, nblks_added)) ALLOCATE (added_sizes(nblks_added)) DO blk = 1, nblks_added IF (PRESENT(blk_pointers)) THEN blk_p = add_blkp(blk) END IF added_blk_info(1:3, blk) = (/add_rows(blk), add_cols(blk), blk_p/) nze = dbcsr_blk_row_size(matrix, add_rows(blk)) & *dbcsr_blk_column_size(matrix, add_cols(blk)) added_sizes(blk) = nze blk_p = blk_p + nze END DO DEALLOCATE (add_rows) DEALLOCATE (add_cols) IF (PRESENT(blk_pointers)) DEALLOCATE (add_blkp) ! nblks_new = nblks_old + nblks_added ! Possibly high estimate ALLOCATE (new_row_i(nblks_new)) ALLOCATE (new_col_i(nblks_new)) ALLOCATE (new_blk_p(nblks_new)) ! Merge the two indices IF (PRESENT(blk_pointers)) THEN CALL merge_index_arrays(new_row_i, new_col_i, new_blk_p, nblks_new, & old_row_i, matrix%col_i, matrix%blk_p, nblks_old, & added_blk_info, nblks_added, added_nblks=nblks_actual_added) data_size_new = 0 ELSE CALL merge_index_arrays(new_row_i, new_col_i, new_blk_p, nblks_new, & old_row_i, matrix%col_i, matrix%blk_p, nblks_old, & added_blk_info, nblks_added, added_nblks=nblks_actual_added, & added_sizes=added_sizes, added_size_offset=data_size_old + 1, & added_size=data_size_new) END IF nblks_new = nblks_actual_added + nblks_old ! Free some memory DEALLOCATE (added_blk_info) DEALLOCATE (added_sizes) DEALLOCATE (old_row_i) ! We can skip this if no block was actually added. IF (nblks_actual_added .GT. 0) THEN ! Write the new index matrix%nblks = nblks_new matrix%nze = matrix%nze + data_size_new matrix%index(dbcsr_slot_nblks) = matrix%nblks matrix%index(dbcsr_slot_nze) = matrix%index(dbcsr_slot_nze) CALL dbcsr_clearfrom_index_array(matrix, dbcsr_slot_col_i) CALL dbcsr_clearfrom_index_array(matrix, dbcsr_slot_blk_p) CALL dbcsr_addto_index_array(matrix, dbcsr_slot_col_i, & new_col_i(1:nblks_new), & extra=nblks_new) CALL dbcsr_addto_index_array(matrix, dbcsr_slot_blk_p, & new_blk_p(1:nblks_new)) CALL dbcsr_make_dbcsr_index(matrix%row_p, new_row_i(1:nblks_new), & nblkrows, nblks_new) IF (.NOT. PRESENT(blk_pointers)) THEN ! Resize data area to fit the new blocks. CALL dbcsr_data_ensure_size(matrix%data_area, & data_size=matrix%nze) ! Zero the new data blocks. CALL dbcsr_data_clear(matrix%data_area, & lb=data_size_old + 1, ub=matrix%nze) END IF END IF CALL timestop(handle) END SUBROUTINE dbcsr_reserve_blocks SUBROUTINE dbcsr_set_block_pointer_any(matrix, pointer_any, & rsize, csize, main_tr, base_offset) !! Sets a pointer, possibly using the buffers. TYPE(dbcsr_type), INTENT(IN) :: matrix !! Matrix to use TYPE(dbcsr_data_obj), INTENT(INOUT) :: pointer_any !! The pointer to set INTEGER, INTENT(IN) :: rsize, csize !! Row sizes of block to point to !! Column sizes of block to point to LOGICAL, INTENT(IN) :: main_tr !! Whether block is transposed in the matrix INTEGER, INTENT(IN) :: base_offset !! The block pointer ! --------------------------------------------------------------------------- IF (main_tr) THEN CALL dbcsr_data_set_pointer(pointer_any, csize, rsize, & matrix%data_area, source_lb=base_offset) ELSE CALL dbcsr_data_set_pointer(pointer_any, rsize, csize, & matrix%data_area, source_lb=base_offset) END IF END SUBROUTINE dbcsr_set_block_pointer_any # 1 "/__w/dbcsr/dbcsr/src/block/../data/dbcsr.fypp" 1 # 9 "/__w/dbcsr/dbcsr/src/block/../data/dbcsr.fypp" # 11 "/__w/dbcsr/dbcsr/src/block/../data/dbcsr.fypp" # 169 "/__w/dbcsr/dbcsr/src/block/../data/dbcsr.fypp" # 658 "/__w/dbcsr/dbcsr/src/block/dbcsr_block_access.F" 2 # 660 "/__w/dbcsr/dbcsr/src/block/dbcsr_block_access.F" SUBROUTINE dbcsr_get_2d_block_p_d (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 2-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_8), DIMENSION(:, :), POINTER :: block !! the block to get (rank-2 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_2d_block_p_d' REAL(kind=real_8), DIMENSION(:), POINTER :: block_1d INTEGER :: rsize, csize, & blk, nze, offset, & stored_row, & stored_col, iw, nwms INTEGER :: error_handle TYPE(btree_data_dp2d) :: data_block LOGICAL :: stored_tr REAL(kind=real_8), DIMENSION(1, 1), TARGET, SAVE :: block0 ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handle) IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_real_8) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize IF (nze .eq. 0) THEN found = .TRUE. block => block0(1:0, 1:0) ELSE block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, 0.0_real_8), offset, offset + nze - 1) CALL dbcsr_set_block_pointer(matrix, block, rsize, csize, offset) END IF ELSEIF (ASSOCIATED(matrix%wms)) THEN nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) THEN IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF CALL btree_find( & matrix%wms(iw)%mutable%m%btree_d, & make_coordinate_tuple(stored_row, stored_col), & data_block, found) IF (found) THEN block => data_block%p END IF END IF END IF IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_2d_block_p_d SUBROUTINE dbcsr_get_block_p_d (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 1-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(IN) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_8), DIMENSION(:), POINTER :: block !! the block to get (rank-1 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block INTEGER :: blk, csize, & nze, offset, & rsize, stored_row, & stored_col LOGICAL :: stored_tr ! --------------------------------------------------------------------------- IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_real_8) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize ! block => pointer_view( & dbcsr_get_data_p(matrix%data_area, 0.0_real_8), offset, offset + nze - 1 & ) ELSEIF (ASSOCIATED(matrix%wms)) THEN IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve rank-1 block pointers from mutable work matrices.") END IF END SUBROUTINE dbcsr_get_block_p_d SUBROUTINE dbcsr_reserve_block2d_d (matrix, row, col, block, & transposed, existed) !! Put a 2-D block in a DBCSR matrix using the btree TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_8), DIMENSION(:, :), POINTER :: block !! the block to reserve; added if not NULL LOGICAL, INTENT(IN), OPTIONAL :: transposed !! the block holds transposed data LOGICAL, INTENT(OUT), OPTIONAL :: existed !! block already existed TYPE(btree_data_dp2d) :: data_block, data_block2 INTEGER :: col_size, row_size, & stored_row, stored_col, & iw, nwms INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size LOGICAL :: found, gift, tr, sym_tr REAL(kind=real_8), DIMENSION(:, :), POINTER :: original_block ! --------------------------------------------------------------------------- gift = ASSOCIATED(block) IF (gift) THEN original_block => block ELSE NULLIFY (original_block) END IF row_blk_size => array_data(matrix%row_blk_size) col_blk_size => array_data(matrix%col_blk_size) row_size = row_blk_size(row) col_size = col_blk_size(col) stored_row = row; stored_col = col IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF sym_tr = .FALSE. CALL dbcsr_get_stored_coordinates(matrix, stored_row, stored_col) IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, work_mutable=.TRUE.) !$OMP MASTER matrix%valid = .FALSE. !$OMP END MASTER !$OMP BARRIER END IF NULLIFY (data_block%p) IF (.NOT. gift) THEN ALLOCATE (data_block%p(row_size, col_size)) block => data_block%p ELSE data_block%p => block END IF data_block%tr = tr nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 CALL btree_add(matrix%wms(iw)%mutable%m%btree_d, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2) IF (.NOT. found) THEN #if defined(_OPENMP) && (200711 <= _OPENMP) !$OMP ATOMIC WRITE matrix%valid = .FALSE. #else !$OMP CRITICAL (critical_reserve_block2d) matrix%valid = .FALSE. !$OMP END CRITICAL (critical_reserve_block2d) #endif matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + row_size*col_size ELSE IF (.NOT. gift) THEN DEALLOCATE (data_block%p) ELSE DEALLOCATE (original_block) END IF block => data_block2%p END IF IF (PRESENT(existed)) existed = found END SUBROUTINE dbcsr_reserve_block2d_d SUBROUTINE dbcsr_put_block2d_d (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Put a 2-D block in a DBCSR matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_8), DIMENSION(:, :), INTENT(IN), & CONTIGUOUS, TARGET :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop REAL(kind=real_8), INTENT(IN), OPTIONAL :: scale !! scale the block being added REAL(kind=real_8), DIMENSION(:), POINTER :: block_1d NULLIFY (block_1d) block_1d(1:SIZE(block)) => block CALL dbcsr_put_block(matrix, row, col, block_1d, lb_row_col, transposed, summation, flop, scale) END SUBROUTINE dbcsr_put_block2d_d SUBROUTINE dbcsr_put_block_d (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Inserts a block in a dbcsr matrix. !! If the block exists, the current data is overwritten. TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the logical row !! the logical column REAL(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop REAL(kind=real_8), INTENT(IN), OPTIONAL :: scale !! scale the OBblock being added TYPE(btree_data_dp2d) :: data_block, data_block2 INTEGER :: blk, col_size, & nze, offset, & row_size, blk_p, & stored_row, stored_col, & iw, nwms LOGICAL :: found, tr, do_sum, tr_diff REAL(kind=real_8), DIMENSION(:), POINTER :: block_1d INTEGER(KIND=int_8) :: my_flop ! --------------------------------------------------------------------------- IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF IF (PRESENT(summation)) THEN do_sum = summation ELSE do_sum = .FALSE. END IF my_flop = 0 row_size = dbcsr_blk_row_size(matrix, row) col_size = dbcsr_blk_column_size(matrix, col) IF (tr) CALL swap(row_size, col_size) stored_row = row; stored_col = col nze = row_size*col_size ! IF (debug_mod .AND. SIZE(block) < nze) & DBCSR_ABORT("Invalid block dimensions") CALL dbcsr_get_stored_block_info(matrix, stored_row, stored_col, & found, blk, lb_row_col, offset) IF (found) THEN ! let's copy the block offset = ABS(offset) ! Fix the index if the new block's transpose flag is different ! from the old one. tr_diff = .FALSE. IF (matrix%blk_p(blk) .LT. 0 .NEQV. tr) THEN tr_diff = .TRUE. matrix%blk_p(blk) = -matrix%blk_p(blk) END IF block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, 0.0_real_8), offset, offset + nze - 1) IF (nze .GT. 0) THEN IF (do_sum) THEN IF (tr_diff) & block_1d = RESHAPE(TRANSPOSE(RESHAPE(block_1d, (/col_size, row_size/))), (/nze/)) IF (PRESENT(scale)) THEN CALL daxpy(nze, scale, block(1:nze), 1, & block_1d, 1) ELSE CALL daxpy(nze, 1.0_real_8, block(1:nze), 1, & block_1d, 1) END IF my_flop = my_flop + nze*2 ELSE IF (PRESENT(scale)) THEN CALL dcopy(nze, scale*block(1:nze), 1, & block_1d, 1) ELSE CALL dcopy(nze, block(1:nze), 1, & block_1d, 1) END IF END IF END IF ELSE !!@@@ !call dbcsr_assert (associated (matrix%wms), dbcsr_fatal_level,& ! dbcsr_caller_error, routineN, "Work matrices not prepared") IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, nblks_guess=1, & sizedata_guess=nze) END IF nwms = SIZE(matrix%wms) iw = 1 !$ IF (debug_mod .AND. nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 blk_p = matrix%wms(iw)%datasize + 1 IF (.NOT. dbcsr_wm_use_mutable(matrix%wms(iw))) THEN IF (tr) blk_p = -blk_p CALL add_work_coordinate(matrix%wms(iw), row, col, blk_p) CALL dbcsr_data_ensure_size(matrix%wms(iw)%data_area, & matrix%wms(iw)%datasize + nze, & factor=default_resize_factor) IF (PRESENT(scale)) THEN CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=scale*block, source_lb=1) ELSE CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=block, source_lb=1) END IF ELSE ALLOCATE (data_block%p(row_size, col_size)) IF (PRESENT(scale)) THEN data_block%p(:, :) = scale*RESHAPE(block, (/row_size, col_size/)) ELSE data_block%p(:, :) = RESHAPE(block, (/row_size, col_size/)) END IF data_block%tr = tr IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF IF (.NOT. do_sum) THEN CALL btree_add( & matrix%wms(iw)%mutable%m%btree_d, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.TRUE.) IF (found) THEN IF (.NOT. ASSOCIATED(data_block2%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block2%p)) DEALLOCATE (data_block2%p) END IF ELSE CALL btree_add( & matrix%wms(iw)%mutable%m%btree_d, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.FALSE.) IF (found) THEN IF (nze > 0) & CALL daxpy(nze, 1.0_real_8, block, 1, & data_block2%p, 1) IF (.NOT. ASSOCIATED(data_block%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block%p)) DEALLOCATE (data_block%p) END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + nze END IF !$OMP ATOMIC WRITE matrix%valid = .FALSE. END IF IF (PRESENT(flop)) flop = flop + my_flop END SUBROUTINE dbcsr_put_block_d SUBROUTINE dbcsr_set_block_pointer_2d_d ( & matrix, pointer_any, rsize, csize, base_offset) !! Sets a pointer, possibly using the buffers. TYPE(dbcsr_type), INTENT(IN) :: matrix !! Matrix to use REAL(kind=real_8), DIMENSION(:, :), POINTER :: pointer_any !! The pointer to set INTEGER, INTENT(IN) :: rsize, csize !! Row size of block to point to !! Column size of block to point to INTEGER, INTENT(IN) :: base_offset !! The block pointer CHARACTER(len=*), PARAMETER :: & routineN = 'dbcsr_set_block_pointer_2d_d' INTEGER :: error_handler REAL(kind=real_8), DIMENSION(:), POINTER :: lin_blk_p ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handler) CALL dbcsr_get_data(matrix%data_area, lin_blk_p, & lb=base_offset, ub=base_offset + rsize*csize - 1) CALL pointer_rank_remap2(pointer_any, rsize, csize, & lin_blk_p) IF (careful_mod) CALL timestop(error_handler) END SUBROUTINE dbcsr_set_block_pointer_2d_d # 660 "/__w/dbcsr/dbcsr/src/block/dbcsr_block_access.F" SUBROUTINE dbcsr_get_2d_block_p_s (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 2-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_4), DIMENSION(:, :), POINTER :: block !! the block to get (rank-2 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_2d_block_p_s' REAL(kind=real_4), DIMENSION(:), POINTER :: block_1d INTEGER :: rsize, csize, & blk, nze, offset, & stored_row, & stored_col, iw, nwms INTEGER :: error_handle TYPE(btree_data_sp2d) :: data_block LOGICAL :: stored_tr REAL(kind=real_4), DIMENSION(1, 1), TARGET, SAVE :: block0 ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handle) IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_real_4) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize IF (nze .eq. 0) THEN found = .TRUE. block => block0(1:0, 1:0) ELSE block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, 0.0_real_4), offset, offset + nze - 1) CALL dbcsr_set_block_pointer(matrix, block, rsize, csize, offset) END IF ELSEIF (ASSOCIATED(matrix%wms)) THEN nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) THEN IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF CALL btree_find( & matrix%wms(iw)%mutable%m%btree_s, & make_coordinate_tuple(stored_row, stored_col), & data_block, found) IF (found) THEN block => data_block%p END IF END IF END IF IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_2d_block_p_s SUBROUTINE dbcsr_get_block_p_s (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 1-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(IN) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_4), DIMENSION(:), POINTER :: block !! the block to get (rank-1 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block INTEGER :: blk, csize, & nze, offset, & rsize, stored_row, & stored_col LOGICAL :: stored_tr ! --------------------------------------------------------------------------- IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_real_4) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize ! block => pointer_view( & dbcsr_get_data_p(matrix%data_area, 0.0_real_4), offset, offset + nze - 1 & ) ELSEIF (ASSOCIATED(matrix%wms)) THEN IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve rank-1 block pointers from mutable work matrices.") END IF END SUBROUTINE dbcsr_get_block_p_s SUBROUTINE dbcsr_reserve_block2d_s (matrix, row, col, block, & transposed, existed) !! Put a 2-D block in a DBCSR matrix using the btree TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_4), DIMENSION(:, :), POINTER :: block !! the block to reserve; added if not NULL LOGICAL, INTENT(IN), OPTIONAL :: transposed !! the block holds transposed data LOGICAL, INTENT(OUT), OPTIONAL :: existed !! block already existed TYPE(btree_data_sp2d) :: data_block, data_block2 INTEGER :: col_size, row_size, & stored_row, stored_col, & iw, nwms INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size LOGICAL :: found, gift, tr, sym_tr REAL(kind=real_4), DIMENSION(:, :), POINTER :: original_block ! --------------------------------------------------------------------------- gift = ASSOCIATED(block) IF (gift) THEN original_block => block ELSE NULLIFY (original_block) END IF row_blk_size => array_data(matrix%row_blk_size) col_blk_size => array_data(matrix%col_blk_size) row_size = row_blk_size(row) col_size = col_blk_size(col) stored_row = row; stored_col = col IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF sym_tr = .FALSE. CALL dbcsr_get_stored_coordinates(matrix, stored_row, stored_col) IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, work_mutable=.TRUE.) !$OMP MASTER matrix%valid = .FALSE. !$OMP END MASTER !$OMP BARRIER END IF NULLIFY (data_block%p) IF (.NOT. gift) THEN ALLOCATE (data_block%p(row_size, col_size)) block => data_block%p ELSE data_block%p => block END IF data_block%tr = tr nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 CALL btree_add(matrix%wms(iw)%mutable%m%btree_s, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2) IF (.NOT. found) THEN #if defined(_OPENMP) && (200711 <= _OPENMP) !$OMP ATOMIC WRITE matrix%valid = .FALSE. #else !$OMP CRITICAL (critical_reserve_block2d) matrix%valid = .FALSE. !$OMP END CRITICAL (critical_reserve_block2d) #endif matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + row_size*col_size ELSE IF (.NOT. gift) THEN DEALLOCATE (data_block%p) ELSE DEALLOCATE (original_block) END IF block => data_block2%p END IF IF (PRESENT(existed)) existed = found END SUBROUTINE dbcsr_reserve_block2d_s SUBROUTINE dbcsr_put_block2d_s (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Put a 2-D block in a DBCSR matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column REAL(kind=real_4), DIMENSION(:, :), INTENT(IN), & CONTIGUOUS, TARGET :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop REAL(kind=real_4), INTENT(IN), OPTIONAL :: scale !! scale the block being added REAL(kind=real_4), DIMENSION(:), POINTER :: block_1d NULLIFY (block_1d) block_1d(1:SIZE(block)) => block CALL dbcsr_put_block(matrix, row, col, block_1d, lb_row_col, transposed, summation, flop, scale) END SUBROUTINE dbcsr_put_block2d_s SUBROUTINE dbcsr_put_block_s (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Inserts a block in a dbcsr matrix. !! If the block exists, the current data is overwritten. TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the logical row !! the logical column REAL(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop REAL(kind=real_4), INTENT(IN), OPTIONAL :: scale !! scale the OBblock being added TYPE(btree_data_sp2d) :: data_block, data_block2 INTEGER :: blk, col_size, & nze, offset, & row_size, blk_p, & stored_row, stored_col, & iw, nwms LOGICAL :: found, tr, do_sum, tr_diff REAL(kind=real_4), DIMENSION(:), POINTER :: block_1d INTEGER(KIND=int_8) :: my_flop ! --------------------------------------------------------------------------- IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF IF (PRESENT(summation)) THEN do_sum = summation ELSE do_sum = .FALSE. END IF my_flop = 0 row_size = dbcsr_blk_row_size(matrix, row) col_size = dbcsr_blk_column_size(matrix, col) IF (tr) CALL swap(row_size, col_size) stored_row = row; stored_col = col nze = row_size*col_size ! IF (debug_mod .AND. SIZE(block) < nze) & DBCSR_ABORT("Invalid block dimensions") CALL dbcsr_get_stored_block_info(matrix, stored_row, stored_col, & found, blk, lb_row_col, offset) IF (found) THEN ! let's copy the block offset = ABS(offset) ! Fix the index if the new block's transpose flag is different ! from the old one. tr_diff = .FALSE. IF (matrix%blk_p(blk) .LT. 0 .NEQV. tr) THEN tr_diff = .TRUE. matrix%blk_p(blk) = -matrix%blk_p(blk) END IF block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, 0.0_real_4), offset, offset + nze - 1) IF (nze .GT. 0) THEN IF (do_sum) THEN IF (tr_diff) & block_1d = RESHAPE(TRANSPOSE(RESHAPE(block_1d, (/col_size, row_size/))), (/nze/)) IF (PRESENT(scale)) THEN CALL saxpy(nze, scale, block(1:nze), 1, & block_1d, 1) ELSE CALL saxpy(nze, 1.0_real_4, block(1:nze), 1, & block_1d, 1) END IF my_flop = my_flop + nze*2 ELSE IF (PRESENT(scale)) THEN CALL scopy(nze, scale*block(1:nze), 1, & block_1d, 1) ELSE CALL scopy(nze, block(1:nze), 1, & block_1d, 1) END IF END IF END IF ELSE !!@@@ !call dbcsr_assert (associated (matrix%wms), dbcsr_fatal_level,& ! dbcsr_caller_error, routineN, "Work matrices not prepared") IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, nblks_guess=1, & sizedata_guess=nze) END IF nwms = SIZE(matrix%wms) iw = 1 !$ IF (debug_mod .AND. nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 blk_p = matrix%wms(iw)%datasize + 1 IF (.NOT. dbcsr_wm_use_mutable(matrix%wms(iw))) THEN IF (tr) blk_p = -blk_p CALL add_work_coordinate(matrix%wms(iw), row, col, blk_p) CALL dbcsr_data_ensure_size(matrix%wms(iw)%data_area, & matrix%wms(iw)%datasize + nze, & factor=default_resize_factor) IF (PRESENT(scale)) THEN CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=scale*block, source_lb=1) ELSE CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=block, source_lb=1) END IF ELSE ALLOCATE (data_block%p(row_size, col_size)) IF (PRESENT(scale)) THEN data_block%p(:, :) = scale*RESHAPE(block, (/row_size, col_size/)) ELSE data_block%p(:, :) = RESHAPE(block, (/row_size, col_size/)) END IF data_block%tr = tr IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF IF (.NOT. do_sum) THEN CALL btree_add( & matrix%wms(iw)%mutable%m%btree_s, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.TRUE.) IF (found) THEN IF (.NOT. ASSOCIATED(data_block2%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block2%p)) DEALLOCATE (data_block2%p) END IF ELSE CALL btree_add( & matrix%wms(iw)%mutable%m%btree_s, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.FALSE.) IF (found) THEN IF (nze > 0) & CALL saxpy(nze, 1.0_real_4, block, 1, & data_block2%p, 1) IF (.NOT. ASSOCIATED(data_block%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block%p)) DEALLOCATE (data_block%p) END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + nze END IF !$OMP ATOMIC WRITE matrix%valid = .FALSE. END IF IF (PRESENT(flop)) flop = flop + my_flop END SUBROUTINE dbcsr_put_block_s SUBROUTINE dbcsr_set_block_pointer_2d_s ( & matrix, pointer_any, rsize, csize, base_offset) !! Sets a pointer, possibly using the buffers. TYPE(dbcsr_type), INTENT(IN) :: matrix !! Matrix to use REAL(kind=real_4), DIMENSION(:, :), POINTER :: pointer_any !! The pointer to set INTEGER, INTENT(IN) :: rsize, csize !! Row size of block to point to !! Column size of block to point to INTEGER, INTENT(IN) :: base_offset !! The block pointer CHARACTER(len=*), PARAMETER :: & routineN = 'dbcsr_set_block_pointer_2d_s' INTEGER :: error_handler REAL(kind=real_4), DIMENSION(:), POINTER :: lin_blk_p ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handler) CALL dbcsr_get_data(matrix%data_area, lin_blk_p, & lb=base_offset, ub=base_offset + rsize*csize - 1) CALL pointer_rank_remap2(pointer_any, rsize, csize, & lin_blk_p) IF (careful_mod) CALL timestop(error_handler) END SUBROUTINE dbcsr_set_block_pointer_2d_s # 660 "/__w/dbcsr/dbcsr/src/block/dbcsr_block_access.F" SUBROUTINE dbcsr_get_2d_block_p_z (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 2-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_8), DIMENSION(:, :), POINTER :: block !! the block to get (rank-2 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_2d_block_p_z' COMPLEX(kind=real_8), DIMENSION(:), POINTER :: block_1d INTEGER :: rsize, csize, & blk, nze, offset, & stored_row, & stored_col, iw, nwms INTEGER :: error_handle TYPE(btree_data_zp2d) :: data_block LOGICAL :: stored_tr COMPLEX(kind=real_8), DIMENSION(1, 1), TARGET, SAVE :: block0 ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handle) IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_complex_8) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize IF (nze .eq. 0) THEN found = .TRUE. block => block0(1:0, 1:0) ELSE block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, CMPLX(0.0, 0.0, real_8)), offset, offset + nze - 1) CALL dbcsr_set_block_pointer(matrix, block, rsize, csize, offset) END IF ELSEIF (ASSOCIATED(matrix%wms)) THEN nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) THEN IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF CALL btree_find( & matrix%wms(iw)%mutable%m%btree_z, & make_coordinate_tuple(stored_row, stored_col), & data_block, found) IF (found) THEN block => data_block%p END IF END IF END IF IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_2d_block_p_z SUBROUTINE dbcsr_get_block_p_z (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 1-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(IN) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_8), DIMENSION(:), POINTER :: block !! the block to get (rank-1 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block INTEGER :: blk, csize, & nze, offset, & rsize, stored_row, & stored_col LOGICAL :: stored_tr ! --------------------------------------------------------------------------- IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_complex_8) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize ! block => pointer_view( & dbcsr_get_data_p(matrix%data_area, CMPLX(0.0, 0.0, real_8)), offset, offset + nze - 1 & ) ELSEIF (ASSOCIATED(matrix%wms)) THEN IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve rank-1 block pointers from mutable work matrices.") END IF END SUBROUTINE dbcsr_get_block_p_z SUBROUTINE dbcsr_reserve_block2d_z (matrix, row, col, block, & transposed, existed) !! Put a 2-D block in a DBCSR matrix using the btree TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_8), DIMENSION(:, :), POINTER :: block !! the block to reserve; added if not NULL LOGICAL, INTENT(IN), OPTIONAL :: transposed !! the block holds transposed data LOGICAL, INTENT(OUT), OPTIONAL :: existed !! block already existed TYPE(btree_data_zp2d) :: data_block, data_block2 INTEGER :: col_size, row_size, & stored_row, stored_col, & iw, nwms INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size LOGICAL :: found, gift, tr, sym_tr COMPLEX(kind=real_8), DIMENSION(:, :), POINTER :: original_block ! --------------------------------------------------------------------------- gift = ASSOCIATED(block) IF (gift) THEN original_block => block ELSE NULLIFY (original_block) END IF row_blk_size => array_data(matrix%row_blk_size) col_blk_size => array_data(matrix%col_blk_size) row_size = row_blk_size(row) col_size = col_blk_size(col) stored_row = row; stored_col = col IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF sym_tr = .FALSE. CALL dbcsr_get_stored_coordinates(matrix, stored_row, stored_col) IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, work_mutable=.TRUE.) !$OMP MASTER matrix%valid = .FALSE. !$OMP END MASTER !$OMP BARRIER END IF NULLIFY (data_block%p) IF (.NOT. gift) THEN ALLOCATE (data_block%p(row_size, col_size)) block => data_block%p ELSE data_block%p => block END IF data_block%tr = tr nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 CALL btree_add(matrix%wms(iw)%mutable%m%btree_z, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2) IF (.NOT. found) THEN #if defined(_OPENMP) && (200711 <= _OPENMP) !$OMP ATOMIC WRITE matrix%valid = .FALSE. #else !$OMP CRITICAL (critical_reserve_block2d) matrix%valid = .FALSE. !$OMP END CRITICAL (critical_reserve_block2d) #endif matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + row_size*col_size ELSE IF (.NOT. gift) THEN DEALLOCATE (data_block%p) ELSE DEALLOCATE (original_block) END IF block => data_block2%p END IF IF (PRESENT(existed)) existed = found END SUBROUTINE dbcsr_reserve_block2d_z SUBROUTINE dbcsr_put_block2d_z (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Put a 2-D block in a DBCSR matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_8), DIMENSION(:, :), INTENT(IN), & CONTIGUOUS, TARGET :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop COMPLEX(kind=real_8), INTENT(IN), OPTIONAL :: scale !! scale the block being added COMPLEX(kind=real_8), DIMENSION(:), POINTER :: block_1d NULLIFY (block_1d) block_1d(1:SIZE(block)) => block CALL dbcsr_put_block(matrix, row, col, block_1d, lb_row_col, transposed, summation, flop, scale) END SUBROUTINE dbcsr_put_block2d_z SUBROUTINE dbcsr_put_block_z (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Inserts a block in a dbcsr matrix. !! If the block exists, the current data is overwritten. TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the logical row !! the logical column COMPLEX(kind=real_8), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop COMPLEX(kind=real_8), INTENT(IN), OPTIONAL :: scale !! scale the OBblock being added TYPE(btree_data_zp2d) :: data_block, data_block2 INTEGER :: blk, col_size, & nze, offset, & row_size, blk_p, & stored_row, stored_col, & iw, nwms LOGICAL :: found, tr, do_sum, tr_diff COMPLEX(kind=real_8), DIMENSION(:), POINTER :: block_1d INTEGER(KIND=int_8) :: my_flop ! --------------------------------------------------------------------------- IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF IF (PRESENT(summation)) THEN do_sum = summation ELSE do_sum = .FALSE. END IF my_flop = 0 row_size = dbcsr_blk_row_size(matrix, row) col_size = dbcsr_blk_column_size(matrix, col) IF (tr) CALL swap(row_size, col_size) stored_row = row; stored_col = col nze = row_size*col_size ! IF (debug_mod .AND. SIZE(block) < nze) & DBCSR_ABORT("Invalid block dimensions") CALL dbcsr_get_stored_block_info(matrix, stored_row, stored_col, & found, blk, lb_row_col, offset) IF (found) THEN ! let's copy the block offset = ABS(offset) ! Fix the index if the new block's transpose flag is different ! from the old one. tr_diff = .FALSE. IF (matrix%blk_p(blk) .LT. 0 .NEQV. tr) THEN tr_diff = .TRUE. matrix%blk_p(blk) = -matrix%blk_p(blk) END IF block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, CMPLX(0.0, 0.0, real_8)), offset, offset + nze - 1) IF (nze .GT. 0) THEN IF (do_sum) THEN IF (tr_diff) & block_1d = RESHAPE(TRANSPOSE(RESHAPE(block_1d, (/col_size, row_size/))), (/nze/)) IF (PRESENT(scale)) THEN CALL zaxpy(nze, scale, block(1:nze), 1, & block_1d, 1) ELSE CALL zaxpy(nze, CMPLX(1.0, 0.0, real_8), block(1:nze), 1, & block_1d, 1) END IF my_flop = my_flop + nze*2 ELSE IF (PRESENT(scale)) THEN CALL zcopy(nze, scale*block(1:nze), 1, & block_1d, 1) ELSE CALL zcopy(nze, block(1:nze), 1, & block_1d, 1) END IF END IF END IF ELSE !!@@@ !call dbcsr_assert (associated (matrix%wms), dbcsr_fatal_level,& ! dbcsr_caller_error, routineN, "Work matrices not prepared") IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, nblks_guess=1, & sizedata_guess=nze) END IF nwms = SIZE(matrix%wms) iw = 1 !$ IF (debug_mod .AND. nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 blk_p = matrix%wms(iw)%datasize + 1 IF (.NOT. dbcsr_wm_use_mutable(matrix%wms(iw))) THEN IF (tr) blk_p = -blk_p CALL add_work_coordinate(matrix%wms(iw), row, col, blk_p) CALL dbcsr_data_ensure_size(matrix%wms(iw)%data_area, & matrix%wms(iw)%datasize + nze, & factor=default_resize_factor) IF (PRESENT(scale)) THEN CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=scale*block, source_lb=1) ELSE CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=block, source_lb=1) END IF ELSE ALLOCATE (data_block%p(row_size, col_size)) IF (PRESENT(scale)) THEN data_block%p(:, :) = scale*RESHAPE(block, (/row_size, col_size/)) ELSE data_block%p(:, :) = RESHAPE(block, (/row_size, col_size/)) END IF data_block%tr = tr IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF IF (.NOT. do_sum) THEN CALL btree_add( & matrix%wms(iw)%mutable%m%btree_z, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.TRUE.) IF (found) THEN IF (.NOT. ASSOCIATED(data_block2%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block2%p)) DEALLOCATE (data_block2%p) END IF ELSE CALL btree_add( & matrix%wms(iw)%mutable%m%btree_z, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.FALSE.) IF (found) THEN IF (nze > 0) & CALL zaxpy(nze, CMPLX(1.0, 0.0, real_8), block, 1, & data_block2%p, 1) IF (.NOT. ASSOCIATED(data_block%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block%p)) DEALLOCATE (data_block%p) END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + nze END IF !$OMP ATOMIC WRITE matrix%valid = .FALSE. END IF IF (PRESENT(flop)) flop = flop + my_flop END SUBROUTINE dbcsr_put_block_z SUBROUTINE dbcsr_set_block_pointer_2d_z ( & matrix, pointer_any, rsize, csize, base_offset) !! Sets a pointer, possibly using the buffers. TYPE(dbcsr_type), INTENT(IN) :: matrix !! Matrix to use COMPLEX(kind=real_8), DIMENSION(:, :), POINTER :: pointer_any !! The pointer to set INTEGER, INTENT(IN) :: rsize, csize !! Row size of block to point to !! Column size of block to point to INTEGER, INTENT(IN) :: base_offset !! The block pointer CHARACTER(len=*), PARAMETER :: & routineN = 'dbcsr_set_block_pointer_2d_z' INTEGER :: error_handler COMPLEX(kind=real_8), DIMENSION(:), POINTER :: lin_blk_p ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handler) CALL dbcsr_get_data(matrix%data_area, lin_blk_p, & lb=base_offset, ub=base_offset + rsize*csize - 1) CALL pointer_rank_remap2(pointer_any, rsize, csize, & lin_blk_p) IF (careful_mod) CALL timestop(error_handler) END SUBROUTINE dbcsr_set_block_pointer_2d_z # 660 "/__w/dbcsr/dbcsr/src/block/dbcsr_block_access.F" SUBROUTINE dbcsr_get_2d_block_p_c (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 2-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_4), DIMENSION(:, :), POINTER :: block !! the block to get (rank-2 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_2d_block_p_c' COMPLEX(kind=real_4), DIMENSION(:), POINTER :: block_1d INTEGER :: rsize, csize, & blk, nze, offset, & stored_row, & stored_col, iw, nwms INTEGER :: error_handle TYPE(btree_data_cp2d) :: data_block LOGICAL :: stored_tr COMPLEX(kind=real_4), DIMENSION(1, 1), TARGET, SAVE :: block0 ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handle) IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_complex_4) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize IF (nze .eq. 0) THEN found = .TRUE. block => block0(1:0, 1:0) ELSE block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, CMPLX(0.0, 0.0, real_4)), offset, offset + nze - 1) CALL dbcsr_set_block_pointer(matrix, block, rsize, csize, offset) END IF ELSEIF (ASSOCIATED(matrix%wms)) THEN nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) THEN IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF CALL btree_find( & matrix%wms(iw)%mutable%m%btree_c, & make_coordinate_tuple(stored_row, stored_col), & data_block, found) IF (found) THEN block => data_block%p END IF END IF END IF IF (careful_mod) CALL timestop(error_handle) END SUBROUTINE dbcsr_get_2d_block_p_c SUBROUTINE dbcsr_get_block_p_c (matrix, row, col, block, tr, found, & row_size, col_size) !! Gets a 1-d block from a dbcsr matrix TYPE(dbcsr_type), INTENT(IN) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_4), DIMENSION(:), POINTER :: block !! the block to get (rank-1 array) LOGICAL, INTENT(OUT) :: tr !! whether the data is transposed LOGICAL, INTENT(OUT) :: found !! whether the block exists in the matrix INTEGER, INTENT(OUT), OPTIONAL :: row_size, col_size !! logical row size of block !! logical column size of block INTEGER :: blk, csize, & nze, offset, & rsize, stored_row, & stored_col LOGICAL :: stored_tr ! --------------------------------------------------------------------------- IF (debug_mod) THEN IF (matrix%data_type /= dbcsr_type_complex_4) & DBCSR_ABORT("Data type mismatch for requested block.") END IF CALL dbcsr_get_block_index(matrix, row, col, stored_row, stored_col, & stored_tr, found, blk, offset) tr = stored_tr rsize = dbcsr_blk_row_size(matrix, stored_row) csize = dbcsr_blk_column_size(matrix, stored_col) IF (PRESENT(row_size)) row_size = rsize IF (PRESENT(col_size)) col_size = csize NULLIFY (block) IF (found) THEN nze = rsize*csize ! block => pointer_view( & dbcsr_get_data_p(matrix%data_area, CMPLX(0.0, 0.0, real_4)), offset, offset + nze - 1 & ) ELSEIF (ASSOCIATED(matrix%wms)) THEN IF (.NOT. dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve blocks from non-mutable work matrices.") IF (dbcsr_use_mutable(matrix)) & DBCSR_ABORT("Can not retrieve rank-1 block pointers from mutable work matrices.") END IF END SUBROUTINE dbcsr_get_block_p_c SUBROUTINE dbcsr_reserve_block2d_c (matrix, row, col, block, & transposed, existed) !! Put a 2-D block in a DBCSR matrix using the btree TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_4), DIMENSION(:, :), POINTER :: block !! the block to reserve; added if not NULL LOGICAL, INTENT(IN), OPTIONAL :: transposed !! the block holds transposed data LOGICAL, INTENT(OUT), OPTIONAL :: existed !! block already existed TYPE(btree_data_cp2d) :: data_block, data_block2 INTEGER :: col_size, row_size, & stored_row, stored_col, & iw, nwms INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size LOGICAL :: found, gift, tr, sym_tr COMPLEX(kind=real_4), DIMENSION(:, :), POINTER :: original_block ! --------------------------------------------------------------------------- gift = ASSOCIATED(block) IF (gift) THEN original_block => block ELSE NULLIFY (original_block) END IF row_blk_size => array_data(matrix%row_blk_size) col_blk_size => array_data(matrix%col_blk_size) row_size = row_blk_size(row) col_size = col_blk_size(col) stored_row = row; stored_col = col IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF sym_tr = .FALSE. CALL dbcsr_get_stored_coordinates(matrix, stored_row, stored_col) IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, work_mutable=.TRUE.) !$OMP MASTER matrix%valid = .FALSE. !$OMP END MASTER !$OMP BARRIER END IF NULLIFY (data_block%p) IF (.NOT. gift) THEN ALLOCATE (data_block%p(row_size, col_size)) block => data_block%p ELSE data_block%p => block END IF data_block%tr = tr nwms = SIZE(matrix%wms) iw = 1 !$ IF (nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 CALL btree_add(matrix%wms(iw)%mutable%m%btree_c, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2) IF (.NOT. found) THEN #if defined(_OPENMP) && (200711 <= _OPENMP) !$OMP ATOMIC WRITE matrix%valid = .FALSE. #else !$OMP CRITICAL (critical_reserve_block2d) matrix%valid = .FALSE. !$OMP END CRITICAL (critical_reserve_block2d) #endif matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + row_size*col_size ELSE IF (.NOT. gift) THEN DEALLOCATE (data_block%p) ELSE DEALLOCATE (original_block) END IF block => data_block2%p END IF IF (PRESENT(existed)) existed = found END SUBROUTINE dbcsr_reserve_block2d_c SUBROUTINE dbcsr_put_block2d_c (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Put a 2-D block in a DBCSR matrix TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the row !! the column COMPLEX(kind=real_4), DIMENSION(:, :), INTENT(IN), & CONTIGUOUS, TARGET :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop COMPLEX(kind=real_4), INTENT(IN), OPTIONAL :: scale !! scale the block being added COMPLEX(kind=real_4), DIMENSION(:), POINTER :: block_1d NULLIFY (block_1d) block_1d(1:SIZE(block)) => block CALL dbcsr_put_block(matrix, row, col, block_1d, lb_row_col, transposed, summation, flop, scale) END SUBROUTINE dbcsr_put_block2d_c SUBROUTINE dbcsr_put_block_c (matrix, row, col, block, lb_row_col, transposed, & summation, flop, scale) !! Inserts a block in a dbcsr matrix. !! If the block exists, the current data is overwritten. TYPE(dbcsr_type), INTENT(INOUT) :: matrix !! DBCSR matrix INTEGER, INTENT(IN) :: row, col !! the logical row !! the logical column COMPLEX(kind=real_4), DIMENSION(:), CONTIGUOUS, INTENT(IN) :: block !! the block to put INTEGER, DIMENSION(2), OPTIONAL, INTENT(INOUT) :: lb_row_col LOGICAL, INTENT(IN), OPTIONAL :: transposed, summation !! the block is transposed !! if block exists, then sum the new block to the old one instead of replacing it INTEGER(KIND=int_8), INTENT(INOUT), OPTIONAL :: flop COMPLEX(kind=real_4), INTENT(IN), OPTIONAL :: scale !! scale the OBblock being added TYPE(btree_data_cp2d) :: data_block, data_block2 INTEGER :: blk, col_size, & nze, offset, & row_size, blk_p, & stored_row, stored_col, & iw, nwms LOGICAL :: found, tr, do_sum, tr_diff COMPLEX(kind=real_4), DIMENSION(:), POINTER :: block_1d INTEGER(KIND=int_8) :: my_flop ! --------------------------------------------------------------------------- IF (PRESENT(transposed)) THEN tr = transposed ELSE tr = .FALSE. END IF IF (PRESENT(summation)) THEN do_sum = summation ELSE do_sum = .FALSE. END IF my_flop = 0 row_size = dbcsr_blk_row_size(matrix, row) col_size = dbcsr_blk_column_size(matrix, col) IF (tr) CALL swap(row_size, col_size) stored_row = row; stored_col = col nze = row_size*col_size ! IF (debug_mod .AND. SIZE(block) < nze) & DBCSR_ABORT("Invalid block dimensions") CALL dbcsr_get_stored_block_info(matrix, stored_row, stored_col, & found, blk, lb_row_col, offset) IF (found) THEN ! let's copy the block offset = ABS(offset) ! Fix the index if the new block's transpose flag is different ! from the old one. tr_diff = .FALSE. IF (matrix%blk_p(blk) .LT. 0 .NEQV. tr) THEN tr_diff = .TRUE. matrix%blk_p(blk) = -matrix%blk_p(blk) END IF block_1d => pointer_view(dbcsr_get_data_p( & matrix%data_area, CMPLX(0.0, 0.0, real_4)), offset, offset + nze - 1) IF (nze .GT. 0) THEN IF (do_sum) THEN IF (tr_diff) & block_1d = RESHAPE(TRANSPOSE(RESHAPE(block_1d, (/col_size, row_size/))), (/nze/)) IF (PRESENT(scale)) THEN CALL caxpy(nze, scale, block(1:nze), 1, & block_1d, 1) ELSE CALL caxpy(nze, CMPLX(1.0, 0.0, real_4), block(1:nze), 1, & block_1d, 1) END IF my_flop = my_flop + nze*2 ELSE IF (PRESENT(scale)) THEN CALL ccopy(nze, scale*block(1:nze), 1, & block_1d, 1) ELSE CALL ccopy(nze, block(1:nze), 1, & block_1d, 1) END IF END IF END IF ELSE !!@@@ !call dbcsr_assert (associated (matrix%wms), dbcsr_fatal_level,& ! dbcsr_caller_error, routineN, "Work matrices not prepared") IF (.NOT. ASSOCIATED(matrix%wms)) THEN CALL dbcsr_work_create(matrix, nblks_guess=1, & sizedata_guess=nze) END IF nwms = SIZE(matrix%wms) iw = 1 !$ IF (debug_mod .AND. nwms < omp_get_num_threads()) & !$ DBCSR_ABORT("Number of work matrices not equal to number of threads") !$ iw = omp_get_thread_num() + 1 blk_p = matrix%wms(iw)%datasize + 1 IF (.NOT. dbcsr_wm_use_mutable(matrix%wms(iw))) THEN IF (tr) blk_p = -blk_p CALL add_work_coordinate(matrix%wms(iw), row, col, blk_p) CALL dbcsr_data_ensure_size(matrix%wms(iw)%data_area, & matrix%wms(iw)%datasize + nze, & factor=default_resize_factor) IF (PRESENT(scale)) THEN CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=scale*block, source_lb=1) ELSE CALL dbcsr_data_set(matrix%wms(iw)%data_area, ABS(blk_p), & data_size=nze, src=block, source_lb=1) END IF ELSE ALLOCATE (data_block%p(row_size, col_size)) IF (PRESENT(scale)) THEN data_block%p(:, :) = scale*RESHAPE(block, (/row_size, col_size/)) ELSE data_block%p(:, :) = RESHAPE(block, (/row_size, col_size/)) END IF data_block%tr = tr IF (.NOT. dbcsr_mutable_instantiated(matrix%wms(iw)%mutable)) THEN CALL dbcsr_mutable_new(matrix%wms(iw)%mutable, & dbcsr_get_data_type(matrix)) END IF IF (.NOT. do_sum) THEN CALL btree_add( & matrix%wms(iw)%mutable%m%btree_c, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.TRUE.) IF (found) THEN IF (.NOT. ASSOCIATED(data_block2%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block2%p)) DEALLOCATE (data_block2%p) END IF ELSE CALL btree_add( & matrix%wms(iw)%mutable%m%btree_c, & make_coordinate_tuple(stored_row, stored_col), & data_block, found, data_block2, replace=.FALSE.) IF (found) THEN IF (nze > 0) & CALL caxpy(nze, CMPLX(1.0, 0.0, real_4), block, 1, & data_block2%p, 1) IF (.NOT. ASSOCIATED(data_block%p)) & DBCSR_WARN("Data was not present in block") IF (ASSOCIATED(data_block%p)) DEALLOCATE (data_block%p) END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%lastblk = matrix%wms(iw)%lastblk + 1 END IF END IF IF (.NOT. found) THEN matrix%wms(iw)%datasize = matrix%wms(iw)%datasize + nze END IF !$OMP ATOMIC WRITE matrix%valid = .FALSE. END IF IF (PRESENT(flop)) flop = flop + my_flop END SUBROUTINE dbcsr_put_block_c SUBROUTINE dbcsr_set_block_pointer_2d_c ( & matrix, pointer_any, rsize, csize, base_offset) !! Sets a pointer, possibly using the buffers. TYPE(dbcsr_type), INTENT(IN) :: matrix !! Matrix to use COMPLEX(kind=real_4), DIMENSION(:, :), POINTER :: pointer_any !! The pointer to set INTEGER, INTENT(IN) :: rsize, csize !! Row size of block to point to !! Column size of block to point to INTEGER, INTENT(IN) :: base_offset !! The block pointer CHARACTER(len=*), PARAMETER :: & routineN = 'dbcsr_set_block_pointer_2d_c' INTEGER :: error_handler COMPLEX(kind=real_4), DIMENSION(:), POINTER :: lin_blk_p ! --------------------------------------------------------------------------- IF (careful_mod) CALL timeset(routineN, error_handler) CALL dbcsr_get_data(matrix%data_area, lin_blk_p, & lb=base_offset, ub=base_offset + rsize*csize - 1) CALL pointer_rank_remap2(pointer_any, rsize, csize, & lin_blk_p) IF (careful_mod) CALL timestop(error_handler) END SUBROUTINE dbcsr_set_block_pointer_2d_c # 1113 "/__w/dbcsr/dbcsr/src/block/dbcsr_block_access.F" END MODULE dbcsr_block_access