dbcsr_scale_by_vector_anytype Subroutine

private subroutine dbcsr_scale_by_vector_anytype(matrix_a, alpha, side)

Scales a DBCSR matrix by alpha

Arguments

Type IntentOptional 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


Source Code

   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