Scales a DBCSR matrix by alpha
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(dbcsr_type), | intent(inout) | :: | matrix_a |
DBCSR matrix |
||
type(dbcsr_data_obj), | intent(in), | optional | :: | alpha |
the scaling vector |
|
character(len=*), | intent(in) | :: | side |
apply the scaling from the side |
SUBROUTINE dbcsr_scale_by_vector_anytype(matrix_a, alpha, side)
!! Scales a DBCSR matrix by alpha
TYPE(dbcsr_type), INTENT(INOUT) :: matrix_a
!! DBCSR matrix
TYPE(dbcsr_data_obj), INTENT(IN), OPTIONAL :: alpha
!! the scaling vector
CHARACTER(LEN=*), INTENT(IN) :: side
!! apply the scaling from the side
CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_scale_by_vector_anytype'
INTEGER :: a_blk, a_col, a_col_size, a_nze, a_row, &
a_row_size, col_offset, data_type, &
handle, i, icol, irow, row_offset
LOGICAL :: right, tr
TYPE(dbcsr_data_obj) :: data_any
TYPE(dbcsr_iterator) :: iter
! ---------------------------------------------------------------------------
CALL timeset(routineN, handle)
! check that alpha and matrix have the same data type
IF (dbcsr_get_data_type(matrix_a) .NE. alpha%d%data_type) &
DBCSR_ABORT("wrong data type matrix_a")
IF (ASSOCIATED(alpha%d%r2_sp) .OR. ASSOCIATED(alpha%d%r2_dp) &
.OR. ASSOCIATED(alpha%d%c2_sp) .OR. ASSOCIATED(alpha%d%c2_dp)) &
DBCSR_ABORT("alpha is not a vector")
!
! set vars
right = .TRUE.
SELECT CASE (side)
CASE ('right'); right = .TRUE.
CASE ('left'); right = .FALSE.
CASE DEFAULT
DBCSR_ABORT("wrong side="//side)
END SELECT
! check that alpha and matrix have matching sizes
IF (right .AND. dbcsr_nfullcols_total(matrix_a) /= dbcsr_data_get_size(alpha)) THEN
DBCSR_ABORT("vector size does not match matrix row size for RHS scaling")
ELSE IF ((.NOT. right) .AND. dbcsr_nfullrows_total(matrix_a) /= dbcsr_data_get_size(alpha)) THEN
DBCSR_ABORT("vector size does not match matrix col size for LHS scaling")
END IF
!
! let's go
data_type = dbcsr_get_data_type(matrix_a)
CALL dbcsr_data_init(data_any)
CALL dbcsr_data_new(data_any, dbcsr_get_data_type(matrix_a))
CALL dbcsr_iterator_start(iter, matrix_a)
DO WHILE (dbcsr_iterator_blocks_left(iter))
CALL dbcsr_iterator_next_block(iter, a_row, a_col, data_any, tr, &
block_number=a_blk, &
row_size=a_row_size, col_size=a_col_size, &
row_offset=row_offset, col_offset=col_offset)
a_nze = a_row_size*a_col_size
IF (a_nze .EQ. 0) CYCLE ! Skip empty blocks
!
! let's scale
IF (right) THEN
SELECT CASE (data_type)
CASE (dbcsr_type_real_4)
DO i = 1, a_col_size
DO icol = (i - 1)*a_row_size + 1, (i - 1)*a_row_size + a_row_size
data_any%d%r_sp(icol) = data_any%d%r_sp(icol)*alpha%d%r_sp(col_offset + i - 1)
END DO
END DO
CASE (dbcsr_type_real_8)
DO i = 1, a_col_size
DO icol = (i - 1)*a_row_size + 1, (i - 1)*a_row_size + a_row_size
data_any%d%r_dp(icol) = data_any%d%r_dp(icol)*alpha%d%r_dp(col_offset + i - 1)
END DO
END DO
CASE (dbcsr_type_complex_4)
DO i = 1, a_col_size
DO icol = (i - 1)*a_row_size + 1, (i - 1)*a_row_size + a_row_size
data_any%d%c_sp(icol) = data_any%d%c_sp(icol)*alpha%d%c_sp(col_offset + i - 1)
END DO
END DO
CASE (dbcsr_type_complex_8)
DO i = 1, a_col_size
DO icol = (i - 1)*a_row_size + 1, (i - 1)*a_row_size + a_row_size
data_any%d%c_dp(icol) = data_any%d%c_dp(icol)*alpha%d%c_dp(col_offset + i - 1)
END DO
END DO
END SELECT
ELSE
SELECT CASE (data_type)
CASE (dbcsr_type_real_4)
DO i = 1, a_row_size
DO irow = i, i + a_col_size*a_row_size - 1, a_row_size
data_any%d%r_sp(irow) = data_any%d%r_sp(irow)*alpha%d%r_sp(row_offset + i - 1)
END DO
END DO
CASE (dbcsr_type_real_8)
DO i = 1, a_row_size
DO irow = i, i + a_col_size*a_row_size - 1, a_row_size
data_any%d%r_dp(irow) = data_any%d%r_dp(irow)*alpha%d%r_dp(row_offset + i - 1)
END DO
END DO
CASE (dbcsr_type_complex_4)
DO i = 1, a_row_size
DO irow = i, i + a_col_size*a_row_size - 1, a_row_size
data_any%d%c_sp(irow) = data_any%d%c_sp(irow)*alpha%d%c_sp(row_offset + i - 1)
END DO
END DO
CASE (dbcsr_type_complex_8)
DO i = 1, a_row_size
DO irow = i, i + a_col_size*a_row_size - 1, a_row_size
data_any%d%c_dp(irow) = data_any%d%c_dp(irow)*alpha%d%c_dp(row_offset + i - 1)
END DO
END DO
END SELECT
END IF
END DO
CALL dbcsr_iterator_stop(iter)
CALL dbcsr_data_clear_pointer(data_any)
CALL dbcsr_data_release(data_any)
CALL timestop(handle)
END SUBROUTINE dbcsr_scale_by_vector_anytype