fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Fix multivect assembly and comments in base_vect

Browse Source
parflow
sfilippone 2 months ago
parent 1cb7634d1f
commit 19ce4a0942
20 changed files with 140 additions and 83 deletions
Show Stats Download Patch File Download Diff File

21
base/modules/serial/psb_c_base_vect_mod.F90
Unescape Escape View File

@ -2677,7 +2677,7 @@ contains
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
call psb_realloc(m,n,x%v,info) call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info,scratch) call x%asb(m,n,info,scratch=scratch)
end subroutine c_base_mlv_bld_n end subroutine c_base_mlv_bld_n
@ -2958,23 +2958,26 @@ contains
case(psb_dupl_err_) case(psb_dupl_err_)
do i=1,ncfs do i=1,ncfs
if (any(vv(x%iv(i),:).ne.czero)) then if (any(vv(x%iv(i),:).ne.czero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb') info = psb_err_duplicate_coo
call psb_errpush(info,'mvect-asb')
return return
else else
vv(x%iv(i),:) = x%v(i,:) vv(x%iv(i),:) = x%v(i,:)
end if end if
end do end do
case default case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl()
info =-7 info =-7
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
else else
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb') call psb_errpush(info,'vect_asb')
@ -2982,8 +2985,10 @@ contains
else else
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
end if end if
call x%set_host() call x%set_host()
call x%set_asb() call x%set_asb()

8
base/modules/serial/psb_c_vect_mod.F90
Unescape Escape View File

@ -1660,19 +1660,20 @@ contains
end subroutine c_mvect_bld_x end subroutine c_mvect_bld_x
subroutine c_mvect_bld_n(x,m,n,mold) subroutine c_mvect_bld_n(x,m,n,mold,scratch)
integer(psb_ipk_), intent(in) :: m,n integer(psb_ipk_), intent(in) :: m,n
class(psb_c_multivect_type), intent(out) :: x class(psb_c_multivect_type), intent(out) :: x
class(psb_c_base_multivect_type), intent(in), optional :: mold class(psb_c_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
info = psb_success_ info = psb_success_
if (present(mold)) then if (present(mold)) then
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
else else
allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default())
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n,scratch=scratch)
end subroutine c_mvect_bld_n end subroutine c_mvect_bld_n
@ -2153,3 +2154,4 @@ contains
!!$ end function c_mvect_asum !!$ end function c_mvect_asum
end module psb_c_multivect_mod end module psb_c_multivect_mod

25
base/modules/serial/psb_d_base_vect_mod.F90
Unescape Escape View File

@ -2189,6 +2189,10 @@ contains
res = min(res,abs(x%v(i))) res = min(res,abs(x%v(i)))
end do end do
#else #else
!
! From M&R: if the array is of size zero, MINVAL
! returns the largest positive value
!
res = minval(x%v(1:n)) res = minval(x%v(1:n))
#endif #endif
end function d_base_min end function d_base_min
@ -2856,7 +2860,7 @@ contains
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
call psb_realloc(m,n,x%v,info) call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info,scratch) call x%asb(m,n,info,scratch=scratch)
end subroutine d_base_mlv_bld_n end subroutine d_base_mlv_bld_n
@ -3137,23 +3141,26 @@ contains
case(psb_dupl_err_) case(psb_dupl_err_)
do i=1,ncfs do i=1,ncfs
if (any(vv(x%iv(i),:).ne.dzero)) then if (any(vv(x%iv(i),:).ne.dzero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb') info = psb_err_duplicate_coo
call psb_errpush(info,'mvect-asb')
return return
else else
vv(x%iv(i),:) = x%v(i,:) vv(x%iv(i),:) = x%v(i,:)
end if end if
end do end do
case default case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl()
info =-7 info =-7
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
else else
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb') call psb_errpush(info,'vect_asb')
@ -3161,8 +3168,10 @@ contains
else else
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
end if end if
call x%set_host() call x%set_host()
call x%set_asb() call x%set_asb()

8
base/modules/serial/psb_d_vect_mod.F90
Unescape Escape View File

@ -1739,19 +1739,20 @@ contains
end subroutine d_mvect_bld_x end subroutine d_mvect_bld_x
subroutine d_mvect_bld_n(x,m,n,mold) subroutine d_mvect_bld_n(x,m,n,mold,scratch)
integer(psb_ipk_), intent(in) :: m,n integer(psb_ipk_), intent(in) :: m,n
class(psb_d_multivect_type), intent(out) :: x class(psb_d_multivect_type), intent(out) :: x
class(psb_d_base_multivect_type), intent(in), optional :: mold class(psb_d_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
info = psb_success_ info = psb_success_
if (present(mold)) then if (present(mold)) then
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
else else
allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default())
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n,scratch=scratch)
end subroutine d_mvect_bld_n end subroutine d_mvect_bld_n
@ -2232,3 +2233,4 @@ contains
!!$ end function d_mvect_asum !!$ end function d_mvect_asum
end module psb_d_multivect_mod end module psb_d_multivect_mod

21
base/modules/serial/psb_i2_base_vect_mod.F90
Unescape Escape View File

@ -1603,7 +1603,7 @@ contains
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
call psb_realloc(m,n,x%v,info) call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info,scratch) call x%asb(m,n,info,scratch=scratch)
end subroutine i2_base_mlv_bld_n end subroutine i2_base_mlv_bld_n
@ -1884,23 +1884,26 @@ contains
case(psb_dupl_err_) case(psb_dupl_err_)
do i=1,ncfs do i=1,ncfs
if (any(vv(x%iv(i),:).ne.i2zero)) then if (any(vv(x%iv(i),:).ne.i2zero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb') info = psb_err_duplicate_coo
call psb_errpush(info,'mvect-asb')
return return
else else
vv(x%iv(i),:) = x%v(i,:) vv(x%iv(i),:) = x%v(i,:)
end if end if
end do end do
case default case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl()
info =-7 info =-7
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
else else
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb') call psb_errpush(info,'vect_asb')
@ -1908,8 +1911,10 @@ contains
else else
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
end if end if
call x%set_host() call x%set_host()
call x%set_asb() call x%set_asb()

8
base/modules/serial/psb_i2_vect_mod.F90
Unescape Escape View File

@ -984,19 +984,20 @@ contains
end subroutine i2_mvect_bld_x end subroutine i2_mvect_bld_x
subroutine i2_mvect_bld_n(x,m,n,mold) subroutine i2_mvect_bld_n(x,m,n,mold,scratch)
integer(psb_ipk_), intent(in) :: m,n integer(psb_ipk_), intent(in) :: m,n
class(psb_i2_multivect_type), intent(out) :: x class(psb_i2_multivect_type), intent(out) :: x
class(psb_i2_base_multivect_type), intent(in), optional :: mold class(psb_i2_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
info = psb_success_ info = psb_success_
if (present(mold)) then if (present(mold)) then
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
else else
allocate(x%v,stat=info, mold=psb_i2_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_i2_get_base_multivect_default())
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n,scratch=scratch)
end subroutine i2_mvect_bld_n end subroutine i2_mvect_bld_n
@ -1269,3 +1270,4 @@ contains
end module psb_i2_multivect_mod end module psb_i2_multivect_mod

21
base/modules/serial/psb_i_base_vect_mod.F90
Unescape Escape View File

@ -1602,7 +1602,7 @@ contains
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
call psb_realloc(m,n,x%v,info) call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info,scratch) call x%asb(m,n,info,scratch=scratch)
end subroutine i_base_mlv_bld_n end subroutine i_base_mlv_bld_n
@ -1883,23 +1883,26 @@ contains
case(psb_dupl_err_) case(psb_dupl_err_)
do i=1,ncfs do i=1,ncfs
if (any(vv(x%iv(i),:).ne.izero)) then if (any(vv(x%iv(i),:).ne.izero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb') info = psb_err_duplicate_coo
call psb_errpush(info,'mvect-asb')
return return
else else
vv(x%iv(i),:) = x%v(i,:) vv(x%iv(i),:) = x%v(i,:)
end if end if
end do end do
case default case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl()
info =-7 info =-7
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
else else
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb') call psb_errpush(info,'vect_asb')
@ -1907,8 +1910,10 @@ contains
else else
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
end if end if
call x%set_host() call x%set_host()
call x%set_asb() call x%set_asb()

8
base/modules/serial/psb_i_vect_mod.F90
Unescape Escape View File

@ -983,19 +983,20 @@ contains
end subroutine i_mvect_bld_x end subroutine i_mvect_bld_x
subroutine i_mvect_bld_n(x,m,n,mold) subroutine i_mvect_bld_n(x,m,n,mold,scratch)
integer(psb_ipk_), intent(in) :: m,n integer(psb_ipk_), intent(in) :: m,n
class(psb_i_multivect_type), intent(out) :: x class(psb_i_multivect_type), intent(out) :: x
class(psb_i_base_multivect_type), intent(in), optional :: mold class(psb_i_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
info = psb_success_ info = psb_success_
if (present(mold)) then if (present(mold)) then
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
else else
allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default())
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n,scratch=scratch)
end subroutine i_mvect_bld_n end subroutine i_mvect_bld_n
@ -1268,3 +1269,4 @@ contains
end module psb_i_multivect_mod end module psb_i_multivect_mod

21
base/modules/serial/psb_l_base_vect_mod.F90
Unescape Escape View File

@ -1603,7 +1603,7 @@ contains
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
call psb_realloc(m,n,x%v,info) call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info,scratch) call x%asb(m,n,info,scratch=scratch)
end subroutine l_base_mlv_bld_n end subroutine l_base_mlv_bld_n
@ -1884,23 +1884,26 @@ contains
case(psb_dupl_err_) case(psb_dupl_err_)
do i=1,ncfs do i=1,ncfs
if (any(vv(x%iv(i),:).ne.lzero)) then if (any(vv(x%iv(i),:).ne.lzero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb') info = psb_err_duplicate_coo
call psb_errpush(info,'mvect-asb')
return return
else else
vv(x%iv(i),:) = x%v(i,:) vv(x%iv(i),:) = x%v(i,:)
end if end if
end do end do
case default case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl()
info =-7 info =-7
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
else else
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb') call psb_errpush(info,'vect_asb')
@ -1908,8 +1911,10 @@ contains
else else
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
end if end if
call x%set_host() call x%set_host()
call x%set_asb() call x%set_asb()

8
base/modules/serial/psb_l_vect_mod.F90
Unescape Escape View File

@ -984,19 +984,20 @@ contains
end subroutine l_mvect_bld_x end subroutine l_mvect_bld_x
subroutine l_mvect_bld_n(x,m,n,mold) subroutine l_mvect_bld_n(x,m,n,mold,scratch)
integer(psb_ipk_), intent(in) :: m,n integer(psb_ipk_), intent(in) :: m,n
class(psb_l_multivect_type), intent(out) :: x class(psb_l_multivect_type), intent(out) :: x
class(psb_l_base_multivect_type), intent(in), optional :: mold class(psb_l_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
info = psb_success_ info = psb_success_
if (present(mold)) then if (present(mold)) then
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
else else
allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default())
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n,scratch=scratch)
end subroutine l_mvect_bld_n end subroutine l_mvect_bld_n
@ -1269,3 +1270,4 @@ contains
end module psb_l_multivect_mod end module psb_l_multivect_mod

25
base/modules/serial/psb_s_base_vect_mod.F90
Unescape Escape View File

@ -2189,6 +2189,10 @@ contains
res = min(res,abs(x%v(i))) res = min(res,abs(x%v(i)))
end do end do
#else #else
!
! From M&R: if the array is of size zero, MINVAL
! returns the largest positive value
!
res = minval(x%v(1:n)) res = minval(x%v(1:n))
#endif #endif
end function s_base_min end function s_base_min
@ -2856,7 +2860,7 @@ contains
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
call psb_realloc(m,n,x%v,info) call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info,scratch) call x%asb(m,n,info,scratch=scratch)
end subroutine s_base_mlv_bld_n end subroutine s_base_mlv_bld_n
@ -3137,23 +3141,26 @@ contains
case(psb_dupl_err_) case(psb_dupl_err_)
do i=1,ncfs do i=1,ncfs
if (any(vv(x%iv(i),:).ne.szero)) then if (any(vv(x%iv(i),:).ne.szero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb') info = psb_err_duplicate_coo
call psb_errpush(info,'mvect-asb')
return return
else else
vv(x%iv(i),:) = x%v(i,:) vv(x%iv(i),:) = x%v(i,:)
end if end if
end do end do
case default case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl()
info =-7 info =-7
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
else else
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb') call psb_errpush(info,'vect_asb')
@ -3161,8 +3168,10 @@ contains
else else
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
end if end if
call x%set_host() call x%set_host()
call x%set_asb() call x%set_asb()

8
base/modules/serial/psb_s_vect_mod.F90
Unescape Escape View File

@ -1739,19 +1739,20 @@ contains
end subroutine s_mvect_bld_x end subroutine s_mvect_bld_x
subroutine s_mvect_bld_n(x,m,n,mold) subroutine s_mvect_bld_n(x,m,n,mold,scratch)
integer(psb_ipk_), intent(in) :: m,n integer(psb_ipk_), intent(in) :: m,n
class(psb_s_multivect_type), intent(out) :: x class(psb_s_multivect_type), intent(out) :: x
class(psb_s_base_multivect_type), intent(in), optional :: mold class(psb_s_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
info = psb_success_ info = psb_success_
if (present(mold)) then if (present(mold)) then
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
else else
allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default())
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n,scratch=scratch)
end subroutine s_mvect_bld_n end subroutine s_mvect_bld_n
@ -2232,3 +2233,4 @@ contains
!!$ end function s_mvect_asum !!$ end function s_mvect_asum
end module psb_s_multivect_mod end module psb_s_multivect_mod

21
base/modules/serial/psb_z_base_vect_mod.F90
Unescape Escape View File

@ -2677,7 +2677,7 @@ contains
logical, intent(in), optional :: scratch logical, intent(in), optional :: scratch
call psb_realloc(m,n,x%v,info) call psb_realloc(m,n,x%v,info)
call x%asb(m,n,info,scratch) call x%asb(m,n,info,scratch=scratch)
end subroutine z_base_mlv_bld_n end subroutine z_base_mlv_bld_n
@ -2958,23 +2958,26 @@ contains
case(psb_dupl_err_) case(psb_dupl_err_)
do i=1,ncfs do i=1,ncfs
if (any(vv(x%iv(i),:).ne.zzero)) then if (any(vv(x%iv(i),:).ne.zzero)) then
call psb_errpush(psb_err_duplicate_coo,'vect-asb') info = psb_err_duplicate_coo
call psb_errpush(info,'mvect-asb')
return return
else else
vv(x%iv(i),:) = x%v(i,:) vv(x%iv(i),:) = x%v(i,:)
end if end if
end do end do
case default case default
write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl()
info =-7 info =-7
end select end select
call psb_move_alloc(vv,x%v,info) call psb_move_alloc(vv,x%v,info)
if (allocated(x%iv)) deallocate(x%iv,stat=info) if (allocated(x%iv)) deallocate(x%iv,stat=info)
else if (x%is_upd().or.x%is_asb().or.scratch_) then else if (x%is_upd().or.x%is_asb().or.scratch_) then
if (x%get_nrows() < m) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
else else
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
call psb_errpush(info,'vect_asb') call psb_errpush(info,'vect_asb')
@ -2982,8 +2985,10 @@ contains
else else
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) & if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info) & call psb_realloc(m,n,x%v,info)
if (info /= 0) & if (info /= 0) then
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') info = psb_err_alloc_dealloc_
call psb_errpush(psb_err_alloc_dealloc_,'mvect_asb')
end if
end if end if
call x%set_host() call x%set_host()
call x%set_asb() call x%set_asb()

8
base/modules/serial/psb_z_vect_mod.F90
Unescape Escape View File

@ -1660,19 +1660,20 @@ contains
end subroutine z_mvect_bld_x end subroutine z_mvect_bld_x
subroutine z_mvect_bld_n(x,m,n,mold) subroutine z_mvect_bld_n(x,m,n,mold,scratch)
integer(psb_ipk_), intent(in) :: m,n integer(psb_ipk_), intent(in) :: m,n
class(psb_z_multivect_type), intent(out) :: x class(psb_z_multivect_type), intent(out) :: x
class(psb_z_base_multivect_type), intent(in), optional :: mold class(psb_z_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
logical, intent(in), optional :: scratch
info = psb_success_ info = psb_success_
if (present(mold)) then if (present(mold)) then
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
else else
allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default())
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n,scratch=scratch)
end subroutine z_mvect_bld_n end subroutine z_mvect_bld_n
@ -2153,3 +2154,4 @@ contains
!!$ end function z_mvect_asum !!$ end function z_mvect_asum
end module psb_z_multivect_mod end module psb_z_multivect_mod

2
base/tools/psb_casb.f90
Unescape Escape View File

@ -309,7 +309,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n)
dupl_ = x%get_dupl() dupl_ = x%get_dupl()
if (scratch_) then if (scratch_) then
call x%free(info) call x%free(info)
call x%bld(ncol,n_,mold=mold) call x%bld(ncol,n_,mold=mold,scratch=.true.)
else else
call x%asb(ncol,n_,info) call x%asb(ncol,n_,info)
! ..update halo elements.. ! ..update halo elements..

2
base/tools/psb_dasb.f90
Unescape Escape View File

@ -309,7 +309,7 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n)
dupl_ = x%get_dupl() dupl_ = x%get_dupl()
if (scratch_) then if (scratch_) then
call x%free(info) call x%free(info)
call x%bld(ncol,n_,mold=mold) call x%bld(ncol,n_,mold=mold,scratch=.true.)
else else
call x%asb(ncol,n_,info) call x%asb(ncol,n_,info)
! ..update halo elements.. ! ..update halo elements..

2
base/tools/psb_iasb.f90
Unescape Escape View File

@ -309,7 +309,7 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n)
dupl_ = x%get_dupl() dupl_ = x%get_dupl()
if (scratch_) then if (scratch_) then
call x%free(info) call x%free(info)
call x%bld(ncol,n_,mold=mold) call x%bld(ncol,n_,mold=mold,scratch=.true.)
else else
call x%asb(ncol,n_,info) call x%asb(ncol,n_,info)
! ..update halo elements.. ! ..update halo elements..

2
base/tools/psb_lasb.f90
Unescape Escape View File

@ -309,7 +309,7 @@ subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n)
dupl_ = x%get_dupl() dupl_ = x%get_dupl()
if (scratch_) then if (scratch_) then
call x%free(info) call x%free(info)
call x%bld(ncol,n_,mold=mold) call x%bld(ncol,n_,mold=mold,scratch=.true.)
else else
call x%asb(ncol,n_,info) call x%asb(ncol,n_,info)
! ..update halo elements.. ! ..update halo elements..

2
base/tools/psb_sasb.f90
Unescape Escape View File

@ -309,7 +309,7 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n)
dupl_ = x%get_dupl() dupl_ = x%get_dupl()
if (scratch_) then if (scratch_) then
call x%free(info) call x%free(info)
call x%bld(ncol,n_,mold=mold) call x%bld(ncol,n_,mold=mold,scratch=.true.)
else else
call x%asb(ncol,n_,info) call x%asb(ncol,n_,info)
! ..update halo elements.. ! ..update halo elements..

2
base/tools/psb_zasb.f90
Unescape Escape View File

@ -309,7 +309,7 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n)
dupl_ = x%get_dupl() dupl_ = x%get_dupl()
if (scratch_) then if (scratch_) then
call x%free(info) call x%free(info)
call x%bld(ncol,n_,mold=mold) call x%bld(ncol,n_,mold=mold,scratch=.true.)
else else
call x%asb(ncol,n_,info) call x%asb(ncol,n_,info)
! ..update halo elements.. ! ..update halo elements..

Write Preview
Loading…
Cancel
Save