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