Scales a DBCSR matrix by alpha
Limits A 4-tuple describing (first_row, last_row, first_column, last_column). Set to 0 to avoid limiting.
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(dbcsr_type), | intent(inout) | :: | matrix_a |
DBCSR matrix |
||
type(dbcsr_scalar_type), | intent(in) | :: | alpha_scalar |
a scalar |
||
integer, | intent(in), | optional, | DIMENSION(4) | :: | limits |
Scale only a subbox |
SUBROUTINE dbcsr_scale_anytype(matrix_a, alpha_scalar, limits)
!! Scales a DBCSR matrix by alpha
!!
!! Limits
!! A 4-tuple describing (first_row, last_row, first_column, last_column). Set
!! to 0 to avoid limiting.
TYPE(dbcsr_type), INTENT(INOUT) :: matrix_a
!! DBCSR matrix
TYPE(dbcsr_scalar_type), INTENT(IN) :: alpha_scalar
!! a scalar
INTEGER, DIMENSION(4), INTENT(IN), OPTIONAL :: limits
!! Scale only a subbox
CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_scale_anytype'
INTEGER, PARAMETER :: first_col_i = 3, first_row_i = 1, &
last_col_i = 4, last_row_i = 2
INTEGER :: a_col, a_col_size, a_row, a_row_size, col_offset, handle, row_offset, &
scale_col_offset, scale_col_size, scale_row_offset, scale_row_size
INTEGER, DIMENSION(4) :: my_limits
LOGICAL :: do_scale, has_limits, tr
TYPE(dbcsr_data_obj) :: data_any
TYPE(dbcsr_iterator) :: iter
TYPE(dbcsr_scalar_type) :: one
! ---------------------------------------------------------------------------
CALL timeset(routineN, handle)
! Limits are only honored if the argument is present and any are
! non-zero.
IF (PRESENT(limits)) THEN
has_limits = ANY(limits(:) .NE. 0)
ELSE
has_limits = .FALSE.
END IF
my_limits(first_row_i) = 1
my_limits(last_row_i) = dbcsr_nfullrows_total(matrix_a)
my_limits(first_col_i) = 1
my_limits(last_col_i) = dbcsr_nfullcols_total(matrix_a)
IF (has_limits) THEN
IF (limits(last_col_i) .NE. 0) THEN
IF (debug_mod .AND. (limits(last_col_i) < 0 .OR. limits(last_col_i) > dbcsr_nfullcols_total(matrix_a))) &
DBCSR_ABORT("Specified last column is out of bounds.")
my_limits(last_col_i) = limits(last_col_i)
END IF
IF (limits(first_col_i) .NE. 0) THEN
IF (debug_mod .AND. (limits(first_col_i) < 0 .OR. limits(first_col_i) > dbcsr_nfullcols_total(matrix_a))) &
DBCSR_ABORT("Specified first column is out of bounds.")
my_limits(first_col_i) = limits(first_col_i)
END IF
IF (limits(last_row_i) .NE. 0) THEN
IF (debug_mod .AND. (limits(last_row_i) < 0 .OR. limits(last_row_i) > dbcsr_nfullrows_total(matrix_a))) &
DBCSR_ABORT("Specified last row is out of bounds.")
my_limits(last_row_i) = limits(last_row_i)
END IF
IF (limits(first_row_i) .NE. 0) THEN
IF (debug_mod .AND. (limits(first_row_i) < 0 .OR. limits(first_row_i) > dbcsr_nfullrows_total(matrix_a))) &
DBCSR_ABORT("Specified first row is out of bounds.")
my_limits(first_row_i) = limits(first_row_i)
END IF
END IF
!
! quick return if possible
one = dbcsr_scalar_one(dbcsr_scalar_get_type(alpha_scalar))
do_scale = .NOT. dbcsr_scalar_are_equal(alpha_scalar, one)
!
! let's go
IF (do_scale) THEN
!$OMP PARALLEL DEFAULT (NONE) &
!$OMP PRIVATE (iter, data_any) &
!$OMP PRIVATE (a_row, a_col, tr, a_row_size, a_col_size, &
!$OMP row_offset, col_offset) &
!$OMP PRIVATE (scale_row_size, scale_col_size,&
!$OMP scale_row_offset, scale_col_offset) &
!$OMP SHARED (matrix_a, my_limits,alpha_scalar)
CALL dbcsr_data_init(data_any)
CALL dbcsr_data_new(data_any, dbcsr_type_1d_to_2d(dbcsr_get_data_type(matrix_a)))
CALL dbcsr_iterator_start(iter, matrix_a, read_only=.FALSE., &
contiguous_pointers=.FALSE., dynamic=.TRUE., &
dynamic_byrows=.TRUE., shared=.TRUE.)
iterations: DO WHILE (dbcsr_iterator_blocks_left(iter))
CALL dbcsr_iterator_next_block(iter, a_row, a_col, data_any, tr, &
row_size=a_row_size, col_size=a_col_size, &
row_offset=row_offset, col_offset=col_offset)
IF (a_row_size .GT. 0 .AND. a_col_size .GT. 0) THEN
CALL frame_block_limit(a_row_size, row_offset, &
my_limits(first_row_i), my_limits(last_row_i), &
scale_row_size, scale_row_offset)
CALL frame_block_limit(a_col_size, col_offset, &
my_limits(first_col_i), my_limits(last_col_i), &
scale_col_size, scale_col_offset)
IF (tr) THEN
CALL swap(scale_row_size, scale_col_size)
CALL swap(scale_row_offset, scale_col_offset)
END IF
CALL dbcsr_block_scale(data_any, scale=alpha_scalar, &
row_size=scale_row_size, col_size=scale_col_size, &
lb=scale_row_offset, lb2=scale_col_offset)
END IF
END DO iterations
CALL dbcsr_iterator_stop(iter)
CALL dbcsr_data_clear_pointer(data_any)
CALL dbcsr_data_release(data_any)
!$OMP END PARALLEL
END IF
CALL timestop(handle)
END SUBROUTINE dbcsr_scale_anytype