Compacts an index.
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(dbcsr_type), | intent(inout) | :: | matrix |
matrix for which to make canonical index |
SUBROUTINE dbcsr_index_compact(matrix)
!! Compacts an index.
TYPE(dbcsr_type), INTENT(INOUT) :: matrix
!! matrix for which to make canonical index
CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_index_compact'
INTEGER :: error_handle, new_size, size_blk_p, &
size_col_i, size_coo_l, size_row_p, &
size_thr_c
INTEGER, ALLOCATABLE, DIMENSION(:) :: blk_p, col_i, coo_l, meta, row_p, thr_c
LOGICAL :: compact, has_blk_p, has_col_i, &
has_coo_l, has_row_p, has_thr_c
! ---------------------------------------------------------------------------
CALL timeset(routineN, error_handle)
! Ensures the index pointers are set.
CALL dbcsr_repoint_index(matrix)
! Check that compaction is even needed.
has_row_p = ASSOCIATED(matrix%row_p)
IF (has_row_p) THEN
size_row_p = SIZE(matrix%row_p)
ELSE
size_row_p = 0
END IF
has_col_i = ASSOCIATED(matrix%col_i)
IF (has_col_i) THEN
size_col_i = SIZE(matrix%col_i)
ELSE
size_col_i = 0
END IF
has_blk_p = ASSOCIATED(matrix%blk_p)
IF (has_blk_p) THEN
size_blk_p = SIZE(matrix%blk_p)
ELSE
size_blk_p = 0
END IF
has_thr_c = ASSOCIATED(matrix%thr_c)
IF (has_thr_c) THEN
size_thr_c = SIZE(matrix%thr_c)
ELSE
size_thr_c = 0
END IF
has_coo_l = ASSOCIATED(matrix%coo_l)
IF (has_coo_l) THEN
size_coo_l = SIZE(matrix%coo_l)
ELSE
size_coo_l = 0
END IF
!
new_size = dbcsr_num_slots + &
size_row_p + size_col_i + size_blk_p + size_thr_c + size_coo_l
compact = new_size .LT. SIZE(matrix%index)
IF (compact) THEN
! Store old index arrays.
IF (has_row_p) THEN
ALLOCATE (row_p(size_row_p))
row_p(:) = matrix%row_p(:)
END IF
IF (has_col_i) THEN
ALLOCATE (col_i(size_col_i))
col_i(:) = matrix%col_i(:)
END IF
IF (has_blk_p) THEN
ALLOCATE (blk_p(size_blk_p))
blk_p(:) = matrix%blk_p(:)
END IF
IF (has_thr_c) THEN
ALLOCATE (thr_c(size_thr_c))
thr_c(:) = matrix%thr_c(:)
END IF
IF (has_coo_l) THEN
ALLOCATE (coo_l(size_coo_l))
coo_l(:) = matrix%coo_l(:)
END IF
ALLOCATE (meta(dbcsr_num_slots))
meta(:) = matrix%index(1:dbcsr_num_slots)
! Clear the index.
CALL memory_deallocate(matrix%index, &
dbcsr_get_index_memory_type(matrix))
NULLIFY (matrix%index)
CALL memory_allocate(matrix%index, new_size, &
dbcsr_get_index_memory_type(matrix))
!
! Now copy the old index arrays into the index. We must not
! copy the positions of the old pointers.
matrix%index(1:dbcsr_meta_size) = meta(1:dbcsr_meta_size)
matrix%index(dbcsr_meta_size + 1:) = 0
matrix%index(dbcsr_slot_size) = dbcsr_num_slots
IF (has_thr_c) THEN
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_thr_c, thr_c)
DEALLOCATE (thr_c)
END IF
IF (has_row_p) THEN
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_row_p, row_p)
DEALLOCATE (row_p)
END IF
IF (has_col_i) THEN
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_col_i, col_i)
DEALLOCATE (col_i)
END IF
IF (has_blk_p) THEN
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_blk_p, blk_p)
DEALLOCATE (blk_p)
END IF
IF (has_coo_l) THEN
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_coo_l, coo_l)
DEALLOCATE (coo_l)
END IF
DEALLOCATE (meta)
IF (careful_mod) THEN
! This is pretty strong but it should be true.
IF (matrix%index(dbcsr_slot_size) /= new_size) &
DBCSR_ABORT("Unexpected index size.")
IF (SIZE(matrix%index) /= new_size) &
DBCSR_ABORT("Unexpected index size.")
END IF
CALL dbcsr_repoint_index(matrix)
END IF
CALL timestop(error_handle)
END SUBROUTINE dbcsr_index_compact