Creates the final dbcsr_type matrix from the working matrix. Work matrices (array or tree-based) are merged into the base DBCSR matrix. If a matrix is marked as having a valid index, then nothing is done. Deleted blocks are pruned from the index.
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(dbcsr_type), | intent(inout) | :: | matrix |
final matrix |
||
logical, | intent(in), | optional | :: | reshuffle |
whether the data should be reshuffled, default is false |
SUBROUTINE dbcsr_finalize(matrix, reshuffle)
!! Creates the final dbcsr_type matrix from the working matrix.
!! Work matrices (array or tree-based) are merged into the base DBCSR matrix.
!! If a matrix is marked as having a valid index, then nothing is done.
!! Deleted blocks are pruned from the index.
TYPE(dbcsr_type), INTENT(INOUT) :: matrix
!! final matrix
LOGICAL, INTENT(IN), OPTIONAL :: reshuffle
!! whether the data should be reshuffled, default is false
CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_finalize'
LOGICAL, PARAMETER :: dbg = .FALSE.
INTEGER :: handle, i, nblks, nwms, start_offset
INTEGER, ALLOCATABLE, DIMENSION(:) :: empty_row_p
INTEGER, DIMENSION(:), POINTER, SAVE :: old_blk_p, old_col_i, old_row_p
LOGICAL :: can_quick, fake_row_p, sort_data, spawn
! ---------------------------------------------------------------------------
CALL timeset(routineN, handle)
NULLIFY (old_blk_p, old_col_i, old_row_p)
!$OMP BARRIER
! If the matrix is not marked as dirty then skip the work.
IF (dbcsr_valid_index(matrix)) THEN
!"No need to finalize a valid matrix, skipping."
!
! A matrix with a valid index should not have associated work
! arrays. This may happen when this routine is called on a
! matrix that was not changed.
!$OMP BARRIER
!$OMP MASTER
IF (ASSOCIATED(matrix%wms)) &
CALL dbcsr_work_destroy_all(matrix)
matrix%valid = .TRUE.
!$OMP END MASTER
!$OMP BARRIER
CALL timestop(handle)
RETURN
END IF
!
! If possible, data copying is avoided.
IF (PRESENT(reshuffle)) THEN
sort_data = reshuffle
ELSE
sort_data = .FALSE.
END IF
!
! Now make sure that a valid row_p exists. Also clear the row_p if
! the matrix is declared to have 0 blocks.
!$OMP MASTER
fake_row_p = .NOT. ASSOCIATED(matrix%row_p)
IF (ASSOCIATED(matrix%row_p)) THEN
fake_row_p = SIZE(matrix%row_p) .LE. 1
END IF
fake_row_p = fake_row_p .OR. matrix%nblks .EQ. 0
!$OMP END MASTER
!
! See where data will be appended in the main data
! area. Alternatively, set to the start if the matrix is declared
! to have no data. (This value is ignored if reshuffle is true
! because the main data area is always new.)
start_offset = matrix%nze
i = dbcsr_get_data_size_used(matrix)
!$OMP MASTER
matrix%nze = 0
!$OMP END MASTER
!$OMP BARRIER
!$OMP ATOMIC
matrix%nze = matrix%nze + i
!$OMP BARRIER
IF (dbg) THEN
WRITE (*, *) routineN//" sizes", matrix%nze, i, &
dbcsr_data_get_size_referenced(matrix%data_area), &
dbcsr_data_get_size(matrix%data_area)
END IF
IF (.FALSE. .AND. dbcsr_data_get_size_referenced(matrix%data_area) .NE. &
matrix%nze) THEN
IF (matrix%nze .NE. dbcsr_data_get_size_referenced(matrix%data_area)) &
DBCSR_WARN("Should reshuffle.")
IF (ASSOCIATED(matrix%wms)) THEN
sort_data = .NOT. dbcsr_wm_use_mutable(matrix%wms(1))
END IF
END IF
IF (sort_data .AND. matrix%nze .GT. 0) THEN
CALL dbcsr_add_wm_from_matrix(matrix)
matrix%nze = 0
!$OMP MASTER
fake_row_p = .TRUE.
!$OMP END MASTER
END IF
start_offset = dbcsr_data_get_size_referenced(matrix%data_area) + 1
IF (matrix%nze .EQ. 0) start_offset = 1
!$OMP MASTER
matrix%index(dbcsr_slot_nze) = matrix%nze
IF (fake_row_p) THEN
ALLOCATE (empty_row_p(matrix%nblkrows_total + 1))
empty_row_p(:) = 0
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_row_p, &
DATA=empty_row_p, extra=0)
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_col_i, &
reservation=0)
CALL dbcsr_addto_index_array(matrix, dbcsr_slot_blk_p, &
reservation=0)
CALL dbcsr_repoint_index(matrix)
END IF
!$OMP END MASTER
!
!$OMP BARRIER
can_quick = can_quickly_finalize(matrix)
!$OMP BARRIER
! If the matrix, work matrices, and environment fit several
! criteria, then a quick O(1) finalization is performed.
IF (can_quick .AND. .NOT. sort_data) THEN
CALL quick_finalize(matrix)
ELSE
!
!$OMP MASTER
!
! Create work matrices if not yet existing
IF (.NOT. ASSOCIATED(matrix%wms)) THEN
nwms = 1
!$ nwms = omp_get_num_threads()
CALL dbcsr_work_create(matrix, n=nwms)
END IF
!$OMP END MASTER
!$OMP BARRIER
!
! Ensure index arrays at least exist.
!$OMP DO SCHEDULE (STATIC, 1)
DO i = 1, SIZE(matrix%wms)
IF (.NOT. ASSOCIATED(matrix%wms(i)%row_i)) THEN
CALL ensure_array_size(matrix%wms(i)%row_i, ub=0)
END IF
IF (.NOT. ASSOCIATED(matrix%wms(i)%col_i)) THEN
CALL ensure_array_size(matrix%wms(i)%col_i, ub=0)
END IF
IF (.NOT. ASSOCIATED(matrix%wms(i)%blk_p)) THEN
CALL ensure_array_size(matrix%wms(i)%blk_p, ub=0)
END IF
END DO
!$OMP ENDDO
!
! Check for deleted blocks
!$OMP MASTER
nblks = matrix%row_p(matrix%nblkrows_total + 1)
IF (ANY(matrix%blk_p(1:nblks) .EQ. 0)) THEN
CALL dbcsr_index_prune_deleted(matrix)
END IF
old_row_p => matrix%row_p
old_col_i => matrix%col_i
old_blk_p => matrix%blk_p
!$OMP END MASTER
!
!$OMP BARRIER
! Check to see if we will need to create a parallel environment
! (needed when there are multiple work matrices but we are not
! in an OpenMP parallel section.)
!
! A parallel section is created is used when the matrix has
! more work matrices. It's a shortcut when the finalize is
! called from a non-parallel environment whereas the matrix was
! built/modified in a parallel environment
nwms = SIZE(matrix%wms)
spawn = .FALSE.
!$ IF (.NOT. OMP_IN_PARALLEL()) THEN
!$ IF (nwms .GT. 1) spawn = .TRUE.
!$ END IF
IF (spawn) THEN
!$OMP PARALLEL IF (spawn) &
!$OMP DEFAULT (NONE) &
!$OMP SHARED (matrix, old_row_p, old_col_i, old_blk_p,&
!$OMP start_offset, sort_data)
CALL dbcsr_merge_all(matrix, &
old_row_p, old_col_i, old_blk_p, &
sort_data=sort_data)
!$OMP END PARALLEL
ELSE
CALL dbcsr_merge_all(matrix, &
old_row_p, old_col_i, old_blk_p, &
sort_data=sort_data)
END IF
END IF
!$OMP BARRIER
!$OMP MASTER
! Clean up.
IF (ASSOCIATED(matrix%wms)) THEN
CALL dbcsr_work_destroy_all(matrix)
END IF
matrix%valid = .TRUE.
!$OMP END MASTER
!$OMP BARRIER
IF (dbg) THEN
!$OMP SINGLE
CALL dbcsr_verify_matrix(matrix)
!$OMP END SINGLE
END IF
!$OMP MASTER
IF (fake_row_p) THEN
DEALLOCATE (empty_row_p)
END IF
!$OMP END MASTER
!$OMP BARRIER
CALL timestop(handle)
END SUBROUTINE dbcsr_finalize