sll_m_vector_space_real_array_1d.F90

Go to the documentation of this file.

 
!
module sll_m_vector_space_real_array_1d
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#include "sll_errors.h"
 
   use sll_m_working_precision, only: f64
 
   use sll_m_vector_space_base, only: sll_c_vector_space
 
   implicit none
 
   public :: sll_t_vector_space_real_array_1d
 
   private
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
   integer, parameter :: wp = f64
 
   type, extends(sll_c_vector_space) :: sll_t_vector_space_real_array_1d
 
      real(wp), allocatable :: array(:)
 
   contains
 
      procedure :: copy => copy__real
      procedure :: incr => incr__real
      procedure :: scal => scal__real
 
      procedure :: add => add__real
      procedure :: mult => mult__real
      procedure :: mult_add => mult_add__real
      procedure :: incr_mult => incr_mult__real
      procedure :: lcmb => lcmb__real
      procedure :: incr_lcmb => incr_lcmb__real
 
      procedure :: norm => norm__real
      procedure :: inner => inner__real
 
   end type sll_t_vector_space_real_array_1d
 
   ! Error messages
   character(len=*), parameter :: wrong_type_x = "x not of type 'sll_t_vector_space_real_array_1d'"
   character(len=*), parameter :: wrong_type_y = "y not of type 'sll_t_vector_space_real_array_1d'"
 
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
contains
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
   subroutine copy__real(self, x)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      class(sll_c_vector_space), intent(in) :: x
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % copy"
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         ! Automatic allocation
         self%array(:) = x%array
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine copy__real
 
   !-----------------------------------------------------------------------------
   subroutine incr__real(self, x)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      class(sll_c_vector_space), intent(in) :: x
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % incr"
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         self%array(:) = self%array(:) + x%array(:)
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine incr__real
 
   !-----------------------------------------------------------------------------
   subroutine scal__real(self, a)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      real(wp), intent(in) :: a
 
      self%array(:) = self%array(:)*a
 
   end subroutine scal__real
 
   !-----------------------------------------------------------------------------
   subroutine add__real(self, x, y)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      class(sll_c_vector_space), intent(in) :: x
      class(sll_c_vector_space), intent(in) :: y
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % add"
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         select type (y)
 
         class is (sll_t_vector_space_real_array_1d)
 
            self%array(:) = x%array(:) + y%array(:)
 
         class default
 
            sll_error(this_sub_name, wrong_type_y)
 
         end select
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine add__real
 
   !-----------------------------------------------------------------------------
   subroutine mult__real(self, a, x)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      real(wp), intent(in) :: a
      class(sll_c_vector_space), intent(in) :: x
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % mult"
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         self%array(:) = a*x%array(:)
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine mult__real
 
   !-----------------------------------------------------------------------------
   subroutine mult_add__real(self, a, x, y)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      real(wp), intent(in) :: a
      class(sll_c_vector_space), intent(in) :: x
      class(sll_c_vector_space), intent(in) :: y
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % mult_add"
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         select type (y)
 
         class is (sll_t_vector_space_real_array_1d)
 
            self%array(:) = a*x%array(:) + y%array(:)
 
         class default
 
            sll_error(this_sub_name, wrong_type_y)
 
         end select
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine mult_add__real
 
   !-----------------------------------------------------------------------------
   subroutine incr_mult__real(self, a, x)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      real(wp), intent(in) :: a
      class(sll_c_vector_space), intent(in) :: x
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % incr_mult"
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         self%array(:) = self%array(:) + a*x%array(:)
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine incr_mult__real
 
   !----------------------------------------------------------------------------
   subroutine lcmb__real(self, a, x)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      real(wp), intent(in) :: a(:)
      class(sll_c_vector_space), intent(in) :: x(:)
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % lcmb"
 
      integer :: i
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         ! Construct linear combination incrementally
         self%array(:) = a(1)*x(1)%array(:)
         do i = 2, size(a)
            self%array(:) = self%array(:) + a(i)*x(i)%array(:)
         end do
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine lcmb__real
 
   !-----------------------------------------------------------------------------
   subroutine incr_lcmb__real(self, a, x)
      class(sll_t_vector_space_real_array_1d), intent(inout) :: self
      real(wp), intent(in) :: a(:)
      class(sll_c_vector_space), intent(in) :: x(:)
 
      character(len=*), parameter :: this_sub_name = "sll_t_vector_space_real_array_1d % incr_lcmb"
 
      integer :: i
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         ! Construct linear combination incrementally
         do i = 1, size(a)
            self%array(:) = self%array(:) + a(i)*x(i)%array(:)
         end do
 
      class default
 
         sll_error(this_sub_name, wrong_type_x)
 
      end select
 
   end subroutine incr_lcmb__real
 
   !-----------------------------------------------------------------------------
   function norm__real(self) result(res)
      class(sll_t_vector_space_real_array_1d), intent(in) :: self
      real(wp) :: res
 
      res = norm2(self%array)
 
   end function norm__real
 
   !-----------------------------------------------------------------------------
   function inner__real(self, x) result(res)
      class(sll_t_vector_space_real_array_1d), intent(in) :: self
      class(sll_c_vector_space), intent(in) :: x
      real(wp) :: res
 
      character(len=*), parameter :: this_fun_name = "sll_t_vector_space_real_array_1d % inner"
 
      select type (x)
 
      class is (sll_t_vector_space_real_array_1d)
 
         res = dot_product(self%array, x%array)
 
      class default
 
         sll_error(this_fun_name, wrong_type_x)
 
      end select
 
   end function inner__real
 
end module sll_m_vector_space_real_array_1d