diff --git a/base/modules/psb_c_base_vect_mod.f90 b/base/modules/psb_c_base_vect_mod.f90 index c063abb3..0a9b0c88 100644 --- a/base/modules/psb_c_base_vect_mod.f90 +++ b/base/modules/psb_c_base_vect_mod.f90 @@ -1335,7 +1335,7 @@ end module psb_c_base_vect_mod module psb_c_base_multivect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -1453,14 +1453,14 @@ module psb_c_base_multivect_mod interface psb_c_base_multivect module procedure constructor, size_const - end interface + end interface psb_c_base_multivect contains - + ! ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -1473,8 +1473,8 @@ contains this%v = x call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size !! \param n Size of vector to be built. @@ -1487,7 +1487,7 @@ contains call this%asb(m,n,info) end function size_const - + ! ! Build from a sample ! @@ -1511,7 +1511,7 @@ contains x%v(:,:) = this(:,:) end subroutine c_base_mlv_bld_x - + ! ! Create with size, but no initialization ! @@ -1531,7 +1531,7 @@ contains call x%asb(m,n,info) end subroutine c_base_mlv_bld_n - + !> Function base_mlv_all: !! \memberof psb_c_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1546,9 +1546,9 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(m,n,x%v,info) - + end subroutine c_base_mlv_all !> Function base_mlv_mold: @@ -1564,7 +1564,7 @@ contains class(psb_c_base_multivect_type), intent(in) :: x class(psb_c_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_c_base_multivect_type :: y, stat=info) end subroutine c_base_mlv_mold @@ -1643,8 +1643,8 @@ contains case default info = 321 -! !$ call psb_errpush(info,name) -! !$ goto 9999 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 end select end if if (info /= 0) then @@ -1664,12 +1664,12 @@ contains use psi_serial_mod implicit none class(psb_c_base_multivect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=czero end subroutine c_base_mlv_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -1683,7 +1683,7 @@ contains !! \param info return code !! ! - + subroutine c_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod @@ -1691,7 +1691,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_is_host !! \memberof psb_c_base_multivect_type @@ -1847,7 +1847,7 @@ contains if (allocated(x%v)) res = size(x%v,2) end function c_base_mlv_get_ncols - + ! !> Function base_mlv_get_sizeof !! \memberof psb_c_base_multivect_type @@ -1858,7 +1858,7 @@ contains implicit none class(psb_c_base_multivect_type), intent(in) :: x integer(psb_long_int_k_) :: res - + ! Force 8-byte integers. res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() @@ -1875,7 +1875,7 @@ contains character(len=5) :: res res = 'BASE' end function c_base_mlv_get_fmt - + ! ! @@ -1900,7 +1900,7 @@ contains end if res(1:m,1:n) = x%v(1:m,1:n) end function c_base_mlv_get_vect - + ! ! Reset all values ! @@ -1913,10 +1913,10 @@ contains subroutine c_base_mlv_set_scal(x,val) class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val - + integer(psb_ipk_) :: info x%v = val - + end subroutine c_base_mlv_set_scal ! @@ -1934,7 +1934,7 @@ contains if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) - + x%v(1:nr,1:nc) = val(1:nr,1:nc) else x%v = val @@ -1977,7 +1977,7 @@ contains do j=1,nc res(j) = cdotc(n,x%v(:,j),1,y%v(:,j),1) end do - class default + class default res = y%dot(n,x%v) end select @@ -2010,7 +2010,7 @@ contains end do end function c_base_mlv_dot_a - + ! ! AXPBY is invoked via Y, hence the structure below. ! @@ -2044,7 +2044,7 @@ contains select type(xx => x) type is (psb_c_base_multivect_type) call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default + class default call y%axpby(m,alpha,x%v,beta,info,n=n) end select @@ -2078,12 +2078,12 @@ contains else nc = min(size(x,2),psb_size(y%v,2)) end if - + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - + end subroutine c_base_mlv_axpby_a - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) @@ -2109,7 +2109,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine c_base_mlv_mlt_mv subroutine c_base_mlv_mlt_mv_v(x, y, info) @@ -2122,7 +2122,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine c_base_mlv_mlt_mv_v ! @@ -2145,7 +2145,7 @@ contains do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do - + end subroutine c_base_mlv_mlt_ar1 ! @@ -2167,7 +2167,7 @@ contains nr = min(psb_size(y%v,1), size(x,1)) nc = min(psb_size(y%v,2), size(x,2)) y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - + end subroutine c_base_mlv_mlt_ar2 @@ -2324,7 +2324,7 @@ contains if (allocated(x%v)) x%v = alpha*x%v end subroutine c_base_mlv_scal - + ! ! Norms 1, 2 and infinity ! @@ -2348,7 +2348,7 @@ contains end do end function c_base_mlv_nrm2 - + ! !> Function base_mlv_amax !! \memberof psb_c_base_multivect_type @@ -2366,7 +2366,7 @@ contains allocate(res(nc)) do j=1,nc res(j) = maxval(abs(x%v(1:n,j))) - end do + end do end function c_base_mlv_amax @@ -2406,7 +2406,7 @@ contains x%v = abs(x%v) call x%set_host() end if - + end subroutine c_base_mlv_absval1 subroutine c_base_mlv_absval2(x,y) @@ -2418,10 +2418,9 @@ contains call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) call y%absval() end if - + end subroutine c_base_mlv_absval2 - - + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2447,7 +2446,7 @@ contains end if nc = psb_size(x%v,2) call psi_gth(n,nc,idx,alpha,x%v,beta,y) - + end subroutine c_base_mlv_gthab ! ! shortcut alpha=1 beta=0 @@ -2485,13 +2484,13 @@ contains complex(psb_spk_) :: y(:) class(psb_c_base_multivect_type) :: x integer(psb_ipk_) :: nc - + if (x%is_dev()) call x%sync() if (.not.allocated(x%v)) then return end if nc = psb_size(x%v,2) - + call psi_gth(n,nc,idx,x%v,y) end subroutine c_base_mlv_gthzv @@ -2515,7 +2514,7 @@ contains complex(psb_spk_) :: beta, x(:) class(psb_c_base_multivect_type) :: y integer(psb_ipk_) :: nc - + if (y%is_dev()) call y%sync() nc = psb_size(y%v,2) call psi_sct(n,nc,idx,x,beta,y%v) @@ -2529,9 +2528,10 @@ contains class(psb_i_base_vect_type) :: idx complex( psb_spk_) :: beta, x(:) class(psb_c_base_multivect_type) :: y - + call y%sct(n,idx%v(i:),x,beta) end subroutine c_base_mlv_sctb_x + end module psb_c_base_multivect_mod diff --git a/base/modules/psb_c_vect_mod.F90 b/base/modules/psb_c_vect_mod.F90 index 4fd06717..869cb460 100644 --- a/base/modules/psb_c_vect_mod.F90 +++ b/base/modules/psb_c_vect_mod.F90 @@ -802,6 +802,8 @@ module psb_c_multivect_mod use psb_c_base_multivect_mod use psb_const_mod + use psb_i_vect_mod + !private @@ -829,11 +831,13 @@ module psb_c_multivect_mod procedure, pass(x) :: set_vect => c_vect_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: clone => c_vect_clone -!!$ procedure, pass(x) :: gthab => c_vect_gthab -!!$ procedure, pass(x) :: gthzv => c_vect_gthzv -!!$ generic, public :: gth => gthab, gthzv -!!$ procedure, pass(y) :: sctb => c_vect_sctb -!!$ generic, public :: sct => sctb + procedure, pass(x) :: gthab => c_vect_gthab + procedure, pass(x) :: gthzv => c_vect_gthzv + procedure, pass(x) :: gthzv_x => c_vect_gthzv_x + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => c_vect_sctb + procedure, pass(y) :: sctb_x => c_vect_sctb_x + generic, public :: sct => sctb, sctb_x !!$ procedure, pass(x) :: dot_v => c_vect_dot_v !!$ procedure, pass(x) :: dot_a => c_vect_dot_a !!$ generic, public :: dot => dot_v, dot_a @@ -1129,38 +1133,62 @@ contains end subroutine c_vect_sync -!!$ subroutine c_vect_gthab(n,idx,alpha,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ complex(psb_spk_) :: alpha, beta, y(:) -!!$ class(psb_c_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,alpha,beta,y) -!!$ -!!$ end subroutine c_vect_gthab -!!$ -!!$ subroutine c_vect_gthzv(n,idx,x,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ complex(psb_spk_) :: y(:) -!!$ class(psb_c_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,y) -!!$ -!!$ end subroutine c_vect_gthzv -!!$ -!!$ subroutine c_vect_sctb(n,idx,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ complex(psb_spk_) :: beta, x(:) -!!$ class(psb_c_multivect_type) :: y -!!$ -!!$ if (allocated(y%v)) & -!!$ & call y%v%sct(n,idx,x,beta) -!!$ -!!$ end subroutine c_vect_sctb + subroutine c_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_spk_) :: alpha, beta, y(:) + class(psb_c_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine c_vect_gthab + + subroutine c_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_spk_) :: y(:) + class(psb_c_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine c_vect_gthzv + + subroutine c_vect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: y(:) + class(psb_c_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine c_vect_gthzv_x + + subroutine c_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_spk_) :: beta, x(:) + class(psb_c_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine c_vect_sctb + + subroutine c_vect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta, x(:) + class(psb_c_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine c_vect_sctb_x subroutine c_vect_free(x, info) use psi_serial_mod diff --git a/base/modules/psb_d_base_vect_mod.f90 b/base/modules/psb_d_base_vect_mod.f90 index c0bc0dd9..67560d70 100644 --- a/base/modules/psb_d_base_vect_mod.f90 +++ b/base/modules/psb_d_base_vect_mod.f90 @@ -1335,7 +1335,7 @@ end module psb_d_base_vect_mod module psb_d_base_multivect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -1453,14 +1453,14 @@ module psb_d_base_multivect_mod interface psb_d_base_multivect module procedure constructor, size_const - end interface + end interface psb_d_base_multivect contains - + ! ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -1473,8 +1473,8 @@ contains this%v = x call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size !! \param n Size of vector to be built. @@ -1487,7 +1487,7 @@ contains call this%asb(m,n,info) end function size_const - + ! ! Build from a sample ! @@ -1511,7 +1511,7 @@ contains x%v(:,:) = this(:,:) end subroutine d_base_mlv_bld_x - + ! ! Create with size, but no initialization ! @@ -1531,7 +1531,7 @@ contains call x%asb(m,n,info) end subroutine d_base_mlv_bld_n - + !> Function base_mlv_all: !! \memberof psb_d_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1546,9 +1546,9 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(m,n,x%v,info) - + end subroutine d_base_mlv_all !> Function base_mlv_mold: @@ -1564,7 +1564,7 @@ contains class(psb_d_base_multivect_type), intent(in) :: x class(psb_d_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_d_base_multivect_type :: y, stat=info) end subroutine d_base_mlv_mold @@ -1643,8 +1643,8 @@ contains case default info = 321 -! !$ call psb_errpush(info,name) -! !$ goto 9999 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 end select end if if (info /= 0) then @@ -1664,12 +1664,12 @@ contains use psi_serial_mod implicit none class(psb_d_base_multivect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=dzero end subroutine d_base_mlv_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -1683,7 +1683,7 @@ contains !! \param info return code !! ! - + subroutine d_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod @@ -1691,7 +1691,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_is_host !! \memberof psb_d_base_multivect_type @@ -1847,7 +1847,7 @@ contains if (allocated(x%v)) res = size(x%v,2) end function d_base_mlv_get_ncols - + ! !> Function base_mlv_get_sizeof !! \memberof psb_d_base_multivect_type @@ -1858,7 +1858,7 @@ contains implicit none class(psb_d_base_multivect_type), intent(in) :: x integer(psb_long_int_k_) :: res - + ! Force 8-byte integers. res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() @@ -1875,7 +1875,7 @@ contains character(len=5) :: res res = 'BASE' end function d_base_mlv_get_fmt - + ! ! @@ -1900,7 +1900,7 @@ contains end if res(1:m,1:n) = x%v(1:m,1:n) end function d_base_mlv_get_vect - + ! ! Reset all values ! @@ -1913,10 +1913,10 @@ contains subroutine d_base_mlv_set_scal(x,val) class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val - + integer(psb_ipk_) :: info x%v = val - + end subroutine d_base_mlv_set_scal ! @@ -1934,7 +1934,7 @@ contains if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) - + x%v(1:nr,1:nc) = val(1:nr,1:nc) else x%v = val @@ -1977,7 +1977,7 @@ contains do j=1,nc res(j) = ddot(n,x%v(:,j),1,y%v(:,j),1) end do - class default + class default res = y%dot(n,x%v) end select @@ -2010,7 +2010,7 @@ contains end do end function d_base_mlv_dot_a - + ! ! AXPBY is invoked via Y, hence the structure below. ! @@ -2044,7 +2044,7 @@ contains select type(xx => x) type is (psb_d_base_multivect_type) call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default + class default call y%axpby(m,alpha,x%v,beta,info,n=n) end select @@ -2078,12 +2078,12 @@ contains else nc = min(size(x,2),psb_size(y%v,2)) end if - + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - + end subroutine d_base_mlv_axpby_a - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) @@ -2109,7 +2109,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine d_base_mlv_mlt_mv subroutine d_base_mlv_mlt_mv_v(x, y, info) @@ -2122,7 +2122,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine d_base_mlv_mlt_mv_v ! @@ -2145,7 +2145,7 @@ contains do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do - + end subroutine d_base_mlv_mlt_ar1 ! @@ -2167,7 +2167,7 @@ contains nr = min(psb_size(y%v,1), size(x,1)) nc = min(psb_size(y%v,2), size(x,2)) y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - + end subroutine d_base_mlv_mlt_ar2 @@ -2324,7 +2324,7 @@ contains if (allocated(x%v)) x%v = alpha*x%v end subroutine d_base_mlv_scal - + ! ! Norms 1, 2 and infinity ! @@ -2348,7 +2348,7 @@ contains end do end function d_base_mlv_nrm2 - + ! !> Function base_mlv_amax !! \memberof psb_d_base_multivect_type @@ -2366,7 +2366,7 @@ contains allocate(res(nc)) do j=1,nc res(j) = maxval(abs(x%v(1:n,j))) - end do + end do end function d_base_mlv_amax @@ -2406,7 +2406,7 @@ contains x%v = abs(x%v) call x%set_host() end if - + end subroutine d_base_mlv_absval1 subroutine d_base_mlv_absval2(x,y) @@ -2418,10 +2418,9 @@ contains call y%axpby(min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) call y%absval() end if - + end subroutine d_base_mlv_absval2 - - + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2447,7 +2446,7 @@ contains end if nc = psb_size(x%v,2) call psi_gth(n,nc,idx,alpha,x%v,beta,y) - + end subroutine d_base_mlv_gthab ! ! shortcut alpha=1 beta=0 @@ -2485,13 +2484,13 @@ contains real(psb_dpk_) :: y(:) class(psb_d_base_multivect_type) :: x integer(psb_ipk_) :: nc - + if (x%is_dev()) call x%sync() if (.not.allocated(x%v)) then return end if nc = psb_size(x%v,2) - + call psi_gth(n,nc,idx,x%v,y) end subroutine d_base_mlv_gthzv @@ -2515,7 +2514,7 @@ contains real(psb_dpk_) :: beta, x(:) class(psb_d_base_multivect_type) :: y integer(psb_ipk_) :: nc - + if (y%is_dev()) call y%sync() nc = psb_size(y%v,2) call psi_sct(n,nc,idx,x,beta,y%v) @@ -2529,9 +2528,10 @@ contains class(psb_i_base_vect_type) :: idx real( psb_dpk_) :: beta, x(:) class(psb_d_base_multivect_type) :: y - + call y%sct(n,idx%v(i:),x,beta) end subroutine d_base_mlv_sctb_x + end module psb_d_base_multivect_mod diff --git a/base/modules/psb_d_vect_mod.F90 b/base/modules/psb_d_vect_mod.F90 index 64ce9b74..4c1b5e6a 100644 --- a/base/modules/psb_d_vect_mod.F90 +++ b/base/modules/psb_d_vect_mod.F90 @@ -802,6 +802,8 @@ module psb_d_multivect_mod use psb_d_base_multivect_mod use psb_const_mod + use psb_i_vect_mod + !private @@ -829,11 +831,13 @@ module psb_d_multivect_mod procedure, pass(x) :: set_vect => d_vect_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: clone => d_vect_clone -!!$ procedure, pass(x) :: gthab => d_vect_gthab -!!$ procedure, pass(x) :: gthzv => d_vect_gthzv -!!$ generic, public :: gth => gthab, gthzv -!!$ procedure, pass(y) :: sctb => d_vect_sctb -!!$ generic, public :: sct => sctb + procedure, pass(x) :: gthab => d_vect_gthab + procedure, pass(x) :: gthzv => d_vect_gthzv + procedure, pass(x) :: gthzv_x => d_vect_gthzv_x + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => d_vect_sctb + procedure, pass(y) :: sctb_x => d_vect_sctb_x + generic, public :: sct => sctb, sctb_x !!$ procedure, pass(x) :: dot_v => d_vect_dot_v !!$ procedure, pass(x) :: dot_a => d_vect_dot_a !!$ generic, public :: dot => dot_v, dot_a @@ -1129,38 +1133,62 @@ contains end subroutine d_vect_sync -!!$ subroutine d_vect_gthab(n,idx,alpha,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ real(psb_dpk_) :: alpha, beta, y(:) -!!$ class(psb_d_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,alpha,beta,y) -!!$ -!!$ end subroutine d_vect_gthab -!!$ -!!$ subroutine d_vect_gthzv(n,idx,x,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ real(psb_dpk_) :: y(:) -!!$ class(psb_d_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,y) -!!$ -!!$ end subroutine d_vect_gthzv -!!$ -!!$ subroutine d_vect_sctb(n,idx,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ real(psb_dpk_) :: beta, x(:) -!!$ class(psb_d_multivect_type) :: y -!!$ -!!$ if (allocated(y%v)) & -!!$ & call y%v%sct(n,idx,x,beta) -!!$ -!!$ end subroutine d_vect_sctb + subroutine d_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_dpk_) :: alpha, beta, y(:) + class(psb_d_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine d_vect_gthab + + subroutine d_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_dpk_) :: y(:) + class(psb_d_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine d_vect_gthzv + + subroutine d_vect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: y(:) + class(psb_d_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine d_vect_gthzv_x + + subroutine d_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_dpk_) :: beta, x(:) + class(psb_d_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine d_vect_sctb + + subroutine d_vect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta, x(:) + class(psb_d_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine d_vect_sctb_x subroutine d_vect_free(x, info) use psi_serial_mod diff --git a/base/modules/psb_i_base_vect_mod.f90 b/base/modules/psb_i_base_vect_mod.f90 index 1edc7a86..6d417d1b 100644 --- a/base/modules/psb_i_base_vect_mod.f90 +++ b/base/modules/psb_i_base_vect_mod.f90 @@ -876,7 +876,7 @@ end module psb_i_base_vect_mod module psb_i_base_multivect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -946,18 +946,29 @@ module psb_i_base_multivect_mod procedure, pass(x) :: set_vect => i_base_mlv_set_vect generic, public :: set => set_vect, set_scal +!!$ ! +!!$ ! Gather/scatter. These are needed for MPI interfacing. +!!$ ! May have to be reworked. +!!$ ! + procedure, pass(x) :: gthab => i_base_mlv_gthab + procedure, pass(x) :: gthzv => i_base_mlv_gthzv + procedure, pass(x) :: gthzv_x => i_base_mlv_gthzv_x + generic, public :: gth => gthab, gthzv, gthzv_x + procedure, pass(y) :: sctb => i_base_mlv_sctb + procedure, pass(y) :: sctb_x => i_base_mlv_sctb_x + generic, public :: sct => sctb, sctb_x end type psb_i_base_multivect_type interface psb_i_base_multivect module procedure constructor, size_const - end interface + end interface psb_i_base_multivect contains - + ! ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -970,8 +981,8 @@ contains this%v = x call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size !! \param n Size of vector to be built. @@ -984,7 +995,7 @@ contains call this%asb(m,n,info) end function size_const - + ! ! Build from a sample ! @@ -1008,7 +1019,7 @@ contains x%v(:,:) = this(:,:) end subroutine i_base_mlv_bld_x - + ! ! Create with size, but no initialization ! @@ -1028,7 +1039,7 @@ contains call x%asb(m,n,info) end subroutine i_base_mlv_bld_n - + !> Function base_mlv_all: !! \memberof psb_i_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1043,9 +1054,9 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(m,n,x%v,info) - + end subroutine i_base_mlv_all !> Function base_mlv_mold: @@ -1061,7 +1072,7 @@ contains class(psb_i_base_multivect_type), intent(in) :: x class(psb_i_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_i_base_multivect_type :: y, stat=info) end subroutine i_base_mlv_mold @@ -1140,8 +1151,8 @@ contains case default info = 321 -! !$ call psb_errpush(info,name) -! !$ goto 9999 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 end select end if if (info /= 0) then @@ -1161,12 +1172,12 @@ contains use psi_serial_mod implicit none class(psb_i_base_multivect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=izero end subroutine i_base_mlv_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -1180,7 +1191,7 @@ contains !! \param info return code !! ! - + subroutine i_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod @@ -1188,7 +1199,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_is_host !! \memberof psb_i_base_multivect_type @@ -1344,7 +1355,7 @@ contains if (allocated(x%v)) res = size(x%v,2) end function i_base_mlv_get_ncols - + ! !> Function base_mlv_get_sizeof !! \memberof psb_i_base_multivect_type @@ -1355,7 +1366,7 @@ contains implicit none class(psb_i_base_multivect_type), intent(in) :: x integer(psb_long_int_k_) :: res - + ! Force 8-byte integers. res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() @@ -1372,7 +1383,7 @@ contains character(len=5) :: res res = 'BASE' end function i_base_mlv_get_fmt - + ! ! @@ -1397,7 +1408,7 @@ contains end if res(1:m,1:n) = x%v(1:m,1:n) end function i_base_mlv_get_vect - + ! ! Reset all values ! @@ -1410,10 +1421,10 @@ contains subroutine i_base_mlv_set_scal(x,val) class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val - + integer(psb_ipk_) :: info x%v = val - + end subroutine i_base_mlv_set_scal ! @@ -1431,7 +1442,7 @@ contains if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) - + x%v(1:nr,1:nc) = val(1:nr,1:nc) else x%v = val @@ -1439,5 +1450,117 @@ contains end subroutine i_base_mlv_set_vect + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + subroutine i_base_mlv_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine i_base_mlv_gthab + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i_base_mlv_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: y(:) + class(psb_i_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine i_base_mlv_gthzv_x + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i_base_mlv_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine i_base_mlv_gthzv + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_i_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + subroutine i_base_mlv_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine i_base_mlv_sctb + + subroutine i_base_mlv_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + integer( psb_ipk_) :: beta, x(:) + class(psb_i_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine i_base_mlv_sctb_x + end module psb_i_base_multivect_mod diff --git a/base/modules/psb_i_vect_mod.F90 b/base/modules/psb_i_vect_mod.F90 index ae5c1e7a..4b5c2188 100644 --- a/base/modules/psb_i_vect_mod.F90 +++ b/base/modules/psb_i_vect_mod.F90 @@ -549,6 +549,8 @@ module psb_i_multivect_mod use psb_i_base_multivect_mod use psb_const_mod + use psb_i_vect_mod + !private @@ -576,11 +578,13 @@ module psb_i_multivect_mod procedure, pass(x) :: set_vect => i_vect_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: clone => i_vect_clone -!!$ procedure, pass(x) :: gthab => i_vect_gthab -!!$ procedure, pass(x) :: gthzv => i_vect_gthzv -!!$ generic, public :: gth => gthab, gthzv -!!$ procedure, pass(y) :: sctb => i_vect_sctb -!!$ generic, public :: sct => sctb + procedure, pass(x) :: gthab => i_vect_gthab + procedure, pass(x) :: gthzv => i_vect_gthzv + procedure, pass(x) :: gthzv_x => i_vect_gthzv_x + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => i_vect_sctb + procedure, pass(y) :: sctb_x => i_vect_sctb_x + generic, public :: sct => sctb, sctb_x end type psb_i_multivect_type public :: psb_i_multivect, psb_i_multivect_type,& @@ -858,38 +862,62 @@ contains end subroutine i_vect_sync -!!$ subroutine i_vect_gthab(n,idx,alpha,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ integer(psb_ipk_) :: alpha, beta, y(:) -!!$ class(psb_i_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,alpha,beta,y) -!!$ -!!$ end subroutine i_vect_gthab -!!$ -!!$ subroutine i_vect_gthzv(n,idx,x,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ integer(psb_ipk_) :: y(:) -!!$ class(psb_i_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,y) -!!$ -!!$ end subroutine i_vect_gthzv -!!$ -!!$ subroutine i_vect_sctb(n,idx,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ integer(psb_ipk_) :: beta, x(:) -!!$ class(psb_i_multivect_type) :: y -!!$ -!!$ if (allocated(y%v)) & -!!$ & call y%v%sct(n,idx,x,beta) -!!$ -!!$ end subroutine i_vect_sctb + subroutine i_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: alpha, beta, y(:) + class(psb_i_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine i_vect_gthab + + subroutine i_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: y(:) + class(psb_i_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine i_vect_gthzv + + subroutine i_vect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: y(:) + class(psb_i_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine i_vect_gthzv_x + + subroutine i_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: beta, x(:) + class(psb_i_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine i_vect_sctb + + subroutine i_vect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta, x(:) + class(psb_i_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine i_vect_sctb_x subroutine i_vect_free(x, info) use psi_serial_mod diff --git a/base/modules/psb_s_base_vect_mod.f90 b/base/modules/psb_s_base_vect_mod.f90 index 36e0ad6c..3e361aac 100644 --- a/base/modules/psb_s_base_vect_mod.f90 +++ b/base/modules/psb_s_base_vect_mod.f90 @@ -1335,7 +1335,7 @@ end module psb_s_base_vect_mod module psb_s_base_multivect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -1453,14 +1453,14 @@ module psb_s_base_multivect_mod interface psb_s_base_multivect module procedure constructor, size_const - end interface + end interface psb_s_base_multivect contains - + ! ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -1473,8 +1473,8 @@ contains this%v = x call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size !! \param n Size of vector to be built. @@ -1487,7 +1487,7 @@ contains call this%asb(m,n,info) end function size_const - + ! ! Build from a sample ! @@ -1511,7 +1511,7 @@ contains x%v(:,:) = this(:,:) end subroutine s_base_mlv_bld_x - + ! ! Create with size, but no initialization ! @@ -1531,7 +1531,7 @@ contains call x%asb(m,n,info) end subroutine s_base_mlv_bld_n - + !> Function base_mlv_all: !! \memberof psb_s_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1546,9 +1546,9 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(m,n,x%v,info) - + end subroutine s_base_mlv_all !> Function base_mlv_mold: @@ -1564,7 +1564,7 @@ contains class(psb_s_base_multivect_type), intent(in) :: x class(psb_s_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_s_base_multivect_type :: y, stat=info) end subroutine s_base_mlv_mold @@ -1643,8 +1643,8 @@ contains case default info = 321 -! !$ call psb_errpush(info,name) -! !$ goto 9999 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 end select end if if (info /= 0) then @@ -1664,12 +1664,12 @@ contains use psi_serial_mod implicit none class(psb_s_base_multivect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=szero end subroutine s_base_mlv_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -1683,7 +1683,7 @@ contains !! \param info return code !! ! - + subroutine s_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod @@ -1691,7 +1691,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_is_host !! \memberof psb_s_base_multivect_type @@ -1847,7 +1847,7 @@ contains if (allocated(x%v)) res = size(x%v,2) end function s_base_mlv_get_ncols - + ! !> Function base_mlv_get_sizeof !! \memberof psb_s_base_multivect_type @@ -1858,7 +1858,7 @@ contains implicit none class(psb_s_base_multivect_type), intent(in) :: x integer(psb_long_int_k_) :: res - + ! Force 8-byte integers. res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() @@ -1875,7 +1875,7 @@ contains character(len=5) :: res res = 'BASE' end function s_base_mlv_get_fmt - + ! ! @@ -1900,7 +1900,7 @@ contains end if res(1:m,1:n) = x%v(1:m,1:n) end function s_base_mlv_get_vect - + ! ! Reset all values ! @@ -1913,10 +1913,10 @@ contains subroutine s_base_mlv_set_scal(x,val) class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val - + integer(psb_ipk_) :: info x%v = val - + end subroutine s_base_mlv_set_scal ! @@ -1934,7 +1934,7 @@ contains if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) - + x%v(1:nr,1:nc) = val(1:nr,1:nc) else x%v = val @@ -1977,7 +1977,7 @@ contains do j=1,nc res(j) = sdot(n,x%v(:,j),1,y%v(:,j),1) end do - class default + class default res = y%dot(n,x%v) end select @@ -2010,7 +2010,7 @@ contains end do end function s_base_mlv_dot_a - + ! ! AXPBY is invoked via Y, hence the structure below. ! @@ -2044,7 +2044,7 @@ contains select type(xx => x) type is (psb_s_base_multivect_type) call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default + class default call y%axpby(m,alpha,x%v,beta,info,n=n) end select @@ -2078,12 +2078,12 @@ contains else nc = min(size(x,2),psb_size(y%v,2)) end if - + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - + end subroutine s_base_mlv_axpby_a - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) @@ -2109,7 +2109,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine s_base_mlv_mlt_mv subroutine s_base_mlv_mlt_mv_v(x, y, info) @@ -2122,7 +2122,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine s_base_mlv_mlt_mv_v ! @@ -2145,7 +2145,7 @@ contains do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do - + end subroutine s_base_mlv_mlt_ar1 ! @@ -2167,7 +2167,7 @@ contains nr = min(psb_size(y%v,1), size(x,1)) nc = min(psb_size(y%v,2), size(x,2)) y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - + end subroutine s_base_mlv_mlt_ar2 @@ -2324,7 +2324,7 @@ contains if (allocated(x%v)) x%v = alpha*x%v end subroutine s_base_mlv_scal - + ! ! Norms 1, 2 and infinity ! @@ -2348,7 +2348,7 @@ contains end do end function s_base_mlv_nrm2 - + ! !> Function base_mlv_amax !! \memberof psb_s_base_multivect_type @@ -2366,7 +2366,7 @@ contains allocate(res(nc)) do j=1,nc res(j) = maxval(abs(x%v(1:n,j))) - end do + end do end function s_base_mlv_amax @@ -2406,7 +2406,7 @@ contains x%v = abs(x%v) call x%set_host() end if - + end subroutine s_base_mlv_absval1 subroutine s_base_mlv_absval2(x,y) @@ -2418,10 +2418,9 @@ contains call y%axpby(min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) call y%absval() end if - + end subroutine s_base_mlv_absval2 - - + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2447,7 +2446,7 @@ contains end if nc = psb_size(x%v,2) call psi_gth(n,nc,idx,alpha,x%v,beta,y) - + end subroutine s_base_mlv_gthab ! ! shortcut alpha=1 beta=0 @@ -2485,13 +2484,13 @@ contains real(psb_spk_) :: y(:) class(psb_s_base_multivect_type) :: x integer(psb_ipk_) :: nc - + if (x%is_dev()) call x%sync() if (.not.allocated(x%v)) then return end if nc = psb_size(x%v,2) - + call psi_gth(n,nc,idx,x%v,y) end subroutine s_base_mlv_gthzv @@ -2515,7 +2514,7 @@ contains real(psb_spk_) :: beta, x(:) class(psb_s_base_multivect_type) :: y integer(psb_ipk_) :: nc - + if (y%is_dev()) call y%sync() nc = psb_size(y%v,2) call psi_sct(n,nc,idx,x,beta,y%v) @@ -2529,9 +2528,10 @@ contains class(psb_i_base_vect_type) :: idx real( psb_spk_) :: beta, x(:) class(psb_s_base_multivect_type) :: y - + call y%sct(n,idx%v(i:),x,beta) end subroutine s_base_mlv_sctb_x + end module psb_s_base_multivect_mod diff --git a/base/modules/psb_s_vect_mod.F90 b/base/modules/psb_s_vect_mod.F90 index 460973e6..b5fa25e4 100644 --- a/base/modules/psb_s_vect_mod.F90 +++ b/base/modules/psb_s_vect_mod.F90 @@ -802,6 +802,8 @@ module psb_s_multivect_mod use psb_s_base_multivect_mod use psb_const_mod + use psb_i_vect_mod + !private @@ -829,11 +831,13 @@ module psb_s_multivect_mod procedure, pass(x) :: set_vect => s_vect_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: clone => s_vect_clone -!!$ procedure, pass(x) :: gthab => s_vect_gthab -!!$ procedure, pass(x) :: gthzv => s_vect_gthzv -!!$ generic, public :: gth => gthab, gthzv -!!$ procedure, pass(y) :: sctb => s_vect_sctb -!!$ generic, public :: sct => sctb + procedure, pass(x) :: gthab => s_vect_gthab + procedure, pass(x) :: gthzv => s_vect_gthzv + procedure, pass(x) :: gthzv_x => s_vect_gthzv_x + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => s_vect_sctb + procedure, pass(y) :: sctb_x => s_vect_sctb_x + generic, public :: sct => sctb, sctb_x !!$ procedure, pass(x) :: dot_v => s_vect_dot_v !!$ procedure, pass(x) :: dot_a => s_vect_dot_a !!$ generic, public :: dot => dot_v, dot_a @@ -1129,38 +1133,62 @@ contains end subroutine s_vect_sync -!!$ subroutine s_vect_gthab(n,idx,alpha,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ real(psb_spk_) :: alpha, beta, y(:) -!!$ class(psb_s_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,alpha,beta,y) -!!$ -!!$ end subroutine s_vect_gthab -!!$ -!!$ subroutine s_vect_gthzv(n,idx,x,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ real(psb_spk_) :: y(:) -!!$ class(psb_s_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,y) -!!$ -!!$ end subroutine s_vect_gthzv -!!$ -!!$ subroutine s_vect_sctb(n,idx,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ real(psb_spk_) :: beta, x(:) -!!$ class(psb_s_multivect_type) :: y -!!$ -!!$ if (allocated(y%v)) & -!!$ & call y%v%sct(n,idx,x,beta) -!!$ -!!$ end subroutine s_vect_sctb + subroutine s_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_spk_) :: alpha, beta, y(:) + class(psb_s_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine s_vect_gthab + + subroutine s_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_spk_) :: y(:) + class(psb_s_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine s_vect_gthzv + + subroutine s_vect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: y(:) + class(psb_s_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine s_vect_gthzv_x + + subroutine s_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_spk_) :: beta, x(:) + class(psb_s_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine s_vect_sctb + + subroutine s_vect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta, x(:) + class(psb_s_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine s_vect_sctb_x subroutine s_vect_free(x, info) use psi_serial_mod diff --git a/base/modules/psb_z_base_vect_mod.f90 b/base/modules/psb_z_base_vect_mod.f90 index e1301048..3179c619 100644 --- a/base/modules/psb_z_base_vect_mod.f90 +++ b/base/modules/psb_z_base_vect_mod.f90 @@ -1335,7 +1335,7 @@ end module psb_z_base_vect_mod module psb_z_base_multivect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -1453,14 +1453,14 @@ module psb_z_base_multivect_mod interface psb_z_base_multivect module procedure constructor, size_const - end interface + end interface psb_z_base_multivect contains - + ! ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -1473,8 +1473,8 @@ contains this%v = x call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size !! \param n Size of vector to be built. @@ -1487,7 +1487,7 @@ contains call this%asb(m,n,info) end function size_const - + ! ! Build from a sample ! @@ -1511,7 +1511,7 @@ contains x%v(:,:) = this(:,:) end subroutine z_base_mlv_bld_x - + ! ! Create with size, but no initialization ! @@ -1531,7 +1531,7 @@ contains call x%asb(m,n,info) end subroutine z_base_mlv_bld_n - + !> Function base_mlv_all: !! \memberof psb_z_base_multivect_type !! \brief Build method with size (uninitialized data) and @@ -1546,9 +1546,9 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(m,n,x%v,info) - + end subroutine z_base_mlv_all !> Function base_mlv_mold: @@ -1564,7 +1564,7 @@ contains class(psb_z_base_multivect_type), intent(in) :: x class(psb_z_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_z_base_multivect_type :: y, stat=info) end subroutine z_base_mlv_mold @@ -1643,8 +1643,8 @@ contains case default info = 321 -! !$ call psb_errpush(info,name) -! !$ goto 9999 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 end select end if if (info /= 0) then @@ -1664,12 +1664,12 @@ contains use psi_serial_mod implicit none class(psb_z_base_multivect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=zzero end subroutine z_base_mlv_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -1683,7 +1683,7 @@ contains !! \param info return code !! ! - + subroutine z_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod @@ -1691,7 +1691,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_is_host !! \memberof psb_z_base_multivect_type @@ -1847,7 +1847,7 @@ contains if (allocated(x%v)) res = size(x%v,2) end function z_base_mlv_get_ncols - + ! !> Function base_mlv_get_sizeof !! \memberof psb_z_base_multivect_type @@ -1858,7 +1858,7 @@ contains implicit none class(psb_z_base_multivect_type), intent(in) :: x integer(psb_long_int_k_) :: res - + ! Force 8-byte integers. res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() @@ -1875,7 +1875,7 @@ contains character(len=5) :: res res = 'BASE' end function z_base_mlv_get_fmt - + ! ! @@ -1900,7 +1900,7 @@ contains end if res(1:m,1:n) = x%v(1:m,1:n) end function z_base_mlv_get_vect - + ! ! Reset all values ! @@ -1913,10 +1913,10 @@ contains subroutine z_base_mlv_set_scal(x,val) class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val - + integer(psb_ipk_) :: info x%v = val - + end subroutine z_base_mlv_set_scal ! @@ -1934,7 +1934,7 @@ contains if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) - + x%v(1:nr,1:nc) = val(1:nr,1:nc) else x%v = val @@ -1977,7 +1977,7 @@ contains do j=1,nc res(j) = zdotc(n,x%v(:,j),1,y%v(:,j),1) end do - class default + class default res = y%dot(n,x%v) end select @@ -2010,7 +2010,7 @@ contains end do end function z_base_mlv_dot_a - + ! ! AXPBY is invoked via Y, hence the structure below. ! @@ -2044,7 +2044,7 @@ contains select type(xx => x) type is (psb_z_base_multivect_type) call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info) - class default + class default call y%axpby(m,alpha,x%v,beta,info,n=n) end select @@ -2078,12 +2078,12 @@ contains else nc = min(size(x,2),psb_size(y%v,2)) end if - + call psb_geaxpby(m,nc,alpha,x,beta,y%v,info) - + end subroutine z_base_mlv_axpby_a - + ! ! Multiple variants of two operations: ! Simple multiplication Y(:.:) = X(:,:)*Y(:,:) @@ -2109,7 +2109,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine z_base_mlv_mlt_mv subroutine z_base_mlv_mlt_mv_v(x, y, info) @@ -2122,7 +2122,7 @@ contains info = 0 if (x%is_dev()) call x%sync() call y%mlt(x%v,info) - + end subroutine z_base_mlv_mlt_mv_v ! @@ -2145,7 +2145,7 @@ contains do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do - + end subroutine z_base_mlv_mlt_ar1 ! @@ -2167,7 +2167,7 @@ contains nr = min(psb_size(y%v,1), size(x,1)) nc = min(psb_size(y%v,2), size(x,2)) y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc) - + end subroutine z_base_mlv_mlt_ar2 @@ -2324,7 +2324,7 @@ contains if (allocated(x%v)) x%v = alpha*x%v end subroutine z_base_mlv_scal - + ! ! Norms 1, 2 and infinity ! @@ -2348,7 +2348,7 @@ contains end do end function z_base_mlv_nrm2 - + ! !> Function base_mlv_amax !! \memberof psb_z_base_multivect_type @@ -2366,7 +2366,7 @@ contains allocate(res(nc)) do j=1,nc res(j) = maxval(abs(x%v(1:n,j))) - end do + end do end function z_base_mlv_amax @@ -2406,7 +2406,7 @@ contains x%v = abs(x%v) call x%set_host() end if - + end subroutine z_base_mlv_absval1 subroutine z_base_mlv_absval2(x,y) @@ -2418,10 +2418,9 @@ contains call y%axpby(min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) call y%absval() end if - + end subroutine z_base_mlv_absval2 - - + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2447,7 +2446,7 @@ contains end if nc = psb_size(x%v,2) call psi_gth(n,nc,idx,alpha,x%v,beta,y) - + end subroutine z_base_mlv_gthab ! ! shortcut alpha=1 beta=0 @@ -2485,13 +2484,13 @@ contains complex(psb_dpk_) :: y(:) class(psb_z_base_multivect_type) :: x integer(psb_ipk_) :: nc - + if (x%is_dev()) call x%sync() if (.not.allocated(x%v)) then return end if nc = psb_size(x%v,2) - + call psi_gth(n,nc,idx,x%v,y) end subroutine z_base_mlv_gthzv @@ -2515,7 +2514,7 @@ contains complex(psb_dpk_) :: beta, x(:) class(psb_z_base_multivect_type) :: y integer(psb_ipk_) :: nc - + if (y%is_dev()) call y%sync() nc = psb_size(y%v,2) call psi_sct(n,nc,idx,x,beta,y%v) @@ -2529,9 +2528,10 @@ contains class(psb_i_base_vect_type) :: idx complex( psb_dpk_) :: beta, x(:) class(psb_z_base_multivect_type) :: y - + call y%sct(n,idx%v(i:),x,beta) end subroutine z_base_mlv_sctb_x + end module psb_z_base_multivect_mod diff --git a/base/modules/psb_z_vect_mod.F90 b/base/modules/psb_z_vect_mod.F90 index 38d14cea..22ec9766 100644 --- a/base/modules/psb_z_vect_mod.F90 +++ b/base/modules/psb_z_vect_mod.F90 @@ -802,6 +802,8 @@ module psb_z_multivect_mod use psb_z_base_multivect_mod use psb_const_mod + use psb_i_vect_mod + !private @@ -829,11 +831,13 @@ module psb_z_multivect_mod procedure, pass(x) :: set_vect => z_vect_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: clone => z_vect_clone -!!$ procedure, pass(x) :: gthab => z_vect_gthab -!!$ procedure, pass(x) :: gthzv => z_vect_gthzv -!!$ generic, public :: gth => gthab, gthzv -!!$ procedure, pass(y) :: sctb => z_vect_sctb -!!$ generic, public :: sct => sctb + procedure, pass(x) :: gthab => z_vect_gthab + procedure, pass(x) :: gthzv => z_vect_gthzv + procedure, pass(x) :: gthzv_x => z_vect_gthzv_x + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => z_vect_sctb + procedure, pass(y) :: sctb_x => z_vect_sctb_x + generic, public :: sct => sctb, sctb_x !!$ procedure, pass(x) :: dot_v => z_vect_dot_v !!$ procedure, pass(x) :: dot_a => z_vect_dot_a !!$ generic, public :: dot => dot_v, dot_a @@ -1129,38 +1133,62 @@ contains end subroutine z_vect_sync -!!$ subroutine z_vect_gthab(n,idx,alpha,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ complex(psb_dpk_) :: alpha, beta, y(:) -!!$ class(psb_z_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,alpha,beta,y) -!!$ -!!$ end subroutine z_vect_gthab -!!$ -!!$ subroutine z_vect_gthzv(n,idx,x,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ complex(psb_dpk_) :: y(:) -!!$ class(psb_z_multivect_type) :: x -!!$ -!!$ if (allocated(x%v)) & -!!$ & call x%v%gth(n,idx,y) -!!$ -!!$ end subroutine z_vect_gthzv -!!$ -!!$ subroutine z_vect_sctb(n,idx,x,beta,y) -!!$ use psi_serial_mod -!!$ integer(psb_ipk_) :: n, idx(:) -!!$ complex(psb_dpk_) :: beta, x(:) -!!$ class(psb_z_multivect_type) :: y -!!$ -!!$ if (allocated(y%v)) & -!!$ & call y%v%sct(n,idx,x,beta) -!!$ -!!$ end subroutine z_vect_sctb + subroutine z_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_dpk_) :: alpha, beta, y(:) + class(psb_z_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine z_vect_gthab + + subroutine z_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_dpk_) :: y(:) + class(psb_z_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine z_vect_gthzv + + subroutine z_vect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: y(:) + class(psb_z_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine z_vect_gthzv_x + + subroutine z_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_dpk_) :: beta, x(:) + class(psb_z_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine z_vect_sctb + + subroutine z_vect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta, x(:) + class(psb_z_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine z_vect_sctb_x subroutine z_vect_free(x, info) use psi_serial_mod diff --git a/base/modules/psi_c_mod.f90 b/base/modules/psi_c_mod.f90 index 7f32f393..3b19977b 100644 --- a/base/modules/psi_c_mod.f90 +++ b/base/modules/psi_c_mod.f90 @@ -31,7 +31,8 @@ !!$ module psi_c_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type - use psb_c_vect_mod, only : psb_c_base_vect_type + use psb_c_base_vect_mod, only : psb_c_base_vect_type + use psb_c_base_multivect_mod, only : psb_c_base_multivect_type interface psi_swapdata @@ -63,6 +64,16 @@ module psi_c_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_vect + subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_cswapdata_multivect subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -92,6 +103,17 @@ module psi_c_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_cswap_vidx_vect + subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_cswap_vidx_multivect end interface @@ -124,6 +146,16 @@ module psi_c_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptran_vect + subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_cswaptran_multivect subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -153,6 +185,17 @@ module psi_c_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ctran_vidx_vect + subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_ctran_vidx_multivect end interface interface psi_ovrl_upd diff --git a/base/modules/psi_d_mod.f90 b/base/modules/psi_d_mod.f90 index a48bc3ae..b1f805d2 100644 --- a/base/modules/psi_d_mod.f90 +++ b/base/modules/psi_d_mod.f90 @@ -31,7 +31,8 @@ !!$ module psi_d_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type - use psb_d_vect_mod, only : psb_d_base_vect_type + use psb_d_base_vect_mod, only : psb_d_base_vect_type + use psb_d_base_multivect_mod, only : psb_d_base_multivect_type interface psi_swapdata @@ -63,6 +64,16 @@ module psi_d_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_vect + subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_dswapdata_multivect subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -92,6 +103,17 @@ module psi_d_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dswap_vidx_vect + subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_dswap_vidx_multivect end interface @@ -124,6 +146,16 @@ module psi_d_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_vect + subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_dswaptran_multivect subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -153,6 +185,17 @@ module psi_d_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dtran_vidx_vect + subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_dtran_vidx_multivect end interface interface psi_ovrl_upd diff --git a/base/modules/psi_i_mod.f90 b/base/modules/psi_i_mod.f90 index 80681068..47222418 100644 --- a/base/modules/psi_i_mod.f90 +++ b/base/modules/psi_i_mod.f90 @@ -31,7 +31,8 @@ !!$ module psi_i_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpik_ - use psb_i_vect_mod, only : psb_i_base_vect_type + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_i_base_multivect_mod, only : psb_i_base_multivect_type interface subroutine psi_compute_size(desc_data,& @@ -223,6 +224,16 @@ module psi_i_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_iswapdata_vect + subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswapdata_multivect subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -252,6 +263,17 @@ module psi_i_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_iswap_vidx_vect + subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_iswap_vidx_multivect end interface @@ -284,6 +306,16 @@ module psi_i_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_iswaptran_vect + subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswaptran_multivect subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -313,6 +345,17 @@ module psi_i_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_itran_vidx_vect + subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_itran_vidx_multivect end interface interface psi_ovrl_upd diff --git a/base/modules/psi_s_mod.f90 b/base/modules/psi_s_mod.f90 index 2ea10fc6..f45dae63 100644 --- a/base/modules/psi_s_mod.f90 +++ b/base/modules/psi_s_mod.f90 @@ -31,7 +31,8 @@ !!$ module psi_s_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type - use psb_s_vect_mod, only : psb_s_base_vect_type + use psb_s_base_vect_mod, only : psb_s_base_vect_type + use psb_s_base_multivect_mod, only : psb_s_base_multivect_type interface psi_swapdata @@ -63,6 +64,16 @@ module psi_s_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_vect + subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_sswapdata_multivect subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -92,6 +103,17 @@ module psi_s_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_sswap_vidx_vect + subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_sswap_vidx_multivect end interface @@ -124,6 +146,16 @@ module psi_s_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptran_vect + subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_sswaptran_multivect subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -153,6 +185,17 @@ module psi_s_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_stran_vidx_vect + subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_stran_vidx_multivect end interface interface psi_ovrl_upd diff --git a/base/modules/psi_z_mod.f90 b/base/modules/psi_z_mod.f90 index ef986916..d3e8eb8e 100644 --- a/base/modules/psi_z_mod.f90 +++ b/base/modules/psi_z_mod.f90 @@ -31,7 +31,8 @@ !!$ module psi_z_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type - use psb_z_vect_mod, only : psb_z_base_vect_type + use psb_z_base_vect_mod, only : psb_z_base_vect_type + use psb_z_base_multivect_mod, only : psb_z_base_multivect_type interface psi_swapdata @@ -63,6 +64,16 @@ module psi_z_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_vect + subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_zswapdata_multivect subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -92,6 +103,17 @@ module psi_z_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_zswap_vidx_vect + subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_zswap_vidx_multivect end interface @@ -124,6 +146,16 @@ module psi_z_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptran_vect + subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_zswaptran_multivect subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -153,6 +185,17 @@ module psi_z_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ztran_vidx_vect + subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_ztran_vidx_multivect end interface interface psi_ovrl_upd