diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index 3f4eb658..ed1b4597 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -115,6 +115,7 @@ module psb_c_base_vect_mod procedure, pass(x) :: is_bld => c_base_is_bld procedure, pass(x) :: is_upd => c_base_is_upd procedure, pass(x) :: is_asb => c_base_is_asb + procedure, pass(x) :: base_cpy => c_base_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -686,7 +687,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -700,7 +701,9 @@ contains & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if + end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine c_base_asb_m @@ -767,7 +770,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -782,6 +785,8 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine c_base_asb_e @@ -1063,6 +1068,24 @@ contains res = .true. end function c_base_is_sync + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine c_base_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine c_base_cpy ! ! Size info. diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index 9c387c13..274bd571 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -64,6 +64,8 @@ module psb_c_vect_mod procedure, pass(x) :: asb => c_vect_asb procedure, pass(x) :: set_dupl => c_vect_set_dupl procedure, pass(x) :: get_dupl => c_vect_get_dupl + procedure, pass(x) :: set_ncfs => c_vect_set_ncfs + procedure, pass(x) :: get_ncfs => c_vect_get_ncfs procedure, pass(x) :: set_state => c_vect_set_state procedure, pass(x) :: set_null => c_vect_set_null procedure, pass(x) :: set_bld => c_vect_set_bld @@ -200,9 +202,9 @@ contains class(psb_c_vect_type), intent(in) :: x integer(psb_ipk_) :: res if (allocated(x%v)) then - res = x%v%get_state() + res = x%v%get_dupl() else - res = psb_vect_null_ + res = psb_dupl_null_ end if end function c_vect_get_dupl @@ -220,6 +222,31 @@ contains end if end subroutine c_vect_set_dupl + function c_vect_get_ncfs(x) result(res) + implicit none + class(psb_c_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function c_vect_get_ncfs + + subroutine c_vect_set_ncfs(x,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine c_vect_set_ncfs + function c_vect_get_state(x) result(res) implicit none class(psb_c_vect_type), intent(in) :: x @@ -311,7 +338,6 @@ contains x%nrmv = val end subroutine c_vect_set_nrmv - function c_vect_is_remote_build(x) result(res) implicit none @@ -618,6 +644,7 @@ contains if (allocated(x%v)) then call x%v%asb(n,info,scratch=scratch) + call x%set_asb() end if end subroutine c_vect_asb @@ -732,6 +759,7 @@ contains if (allocated(x%v%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) call x%v%free(info) endif end if diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index 7a3026ea..71b921cd 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -115,6 +115,7 @@ module psb_d_base_vect_mod procedure, pass(x) :: is_bld => d_base_is_bld procedure, pass(x) :: is_upd => d_base_is_upd procedure, pass(x) :: is_asb => d_base_is_asb + procedure, pass(x) :: base_cpy => d_base_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -693,7 +694,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -707,7 +708,9 @@ contains & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if + end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine d_base_asb_m @@ -774,7 +777,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -789,6 +792,8 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine d_base_asb_e @@ -1070,6 +1075,24 @@ contains res = .true. end function d_base_is_sync + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine d_base_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine d_base_cpy ! ! Size info. diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 4aaab170..4e022653 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -64,6 +64,8 @@ module psb_d_vect_mod procedure, pass(x) :: asb => d_vect_asb procedure, pass(x) :: set_dupl => d_vect_set_dupl procedure, pass(x) :: get_dupl => d_vect_get_dupl + procedure, pass(x) :: set_ncfs => d_vect_set_ncfs + procedure, pass(x) :: get_ncfs => d_vect_get_ncfs procedure, pass(x) :: set_state => d_vect_set_state procedure, pass(x) :: set_null => d_vect_set_null procedure, pass(x) :: set_bld => d_vect_set_bld @@ -207,9 +209,9 @@ contains class(psb_d_vect_type), intent(in) :: x integer(psb_ipk_) :: res if (allocated(x%v)) then - res = x%v%get_state() + res = x%v%get_dupl() else - res = psb_vect_null_ + res = psb_dupl_null_ end if end function d_vect_get_dupl @@ -227,6 +229,31 @@ contains end if end subroutine d_vect_set_dupl + function d_vect_get_ncfs(x) result(res) + implicit none + class(psb_d_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function d_vect_get_ncfs + + subroutine d_vect_set_ncfs(x,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine d_vect_set_ncfs + function d_vect_get_state(x) result(res) implicit none class(psb_d_vect_type), intent(in) :: x @@ -318,7 +345,6 @@ contains x%nrmv = val end subroutine d_vect_set_nrmv - function d_vect_is_remote_build(x) result(res) implicit none @@ -625,6 +651,7 @@ contains if (allocated(x%v)) then call x%v%asb(n,info,scratch=scratch) + call x%set_asb() end if end subroutine d_vect_asb @@ -739,6 +766,7 @@ contains if (allocated(x%v%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) call x%v%free(info) endif end if diff --git a/base/modules/serial/psb_i_base_vect_mod.F90 b/base/modules/serial/psb_i_base_vect_mod.F90 index 5896d32e..f55815cf 100644 --- a/base/modules/serial/psb_i_base_vect_mod.F90 +++ b/base/modules/serial/psb_i_base_vect_mod.F90 @@ -113,6 +113,7 @@ module psb_i_base_vect_mod procedure, pass(x) :: is_bld => i_base_is_bld procedure, pass(x) :: is_upd => i_base_is_upd procedure, pass(x) :: is_asb => i_base_is_asb + procedure, pass(x) :: base_cpy => i_base_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -619,7 +620,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -633,7 +634,9 @@ contains & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if + end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine i_base_asb_m @@ -700,7 +703,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -715,6 +718,8 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine i_base_asb_e @@ -996,6 +1001,24 @@ contains res = .true. end function i_base_is_sync + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine i_base_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i_base_vect_type), intent(in) :: x + class(psb_i_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine i_base_cpy ! ! Size info. diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 9276093d..91230644 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -63,6 +63,8 @@ module psb_i_vect_mod procedure, pass(x) :: asb => i_vect_asb procedure, pass(x) :: set_dupl => i_vect_set_dupl procedure, pass(x) :: get_dupl => i_vect_get_dupl + procedure, pass(x) :: set_ncfs => i_vect_set_ncfs + procedure, pass(x) :: get_ncfs => i_vect_get_ncfs procedure, pass(x) :: set_state => i_vect_set_state procedure, pass(x) :: set_null => i_vect_set_null procedure, pass(x) :: set_bld => i_vect_set_bld @@ -145,9 +147,9 @@ contains class(psb_i_vect_type), intent(in) :: x integer(psb_ipk_) :: res if (allocated(x%v)) then - res = x%v%get_state() + res = x%v%get_dupl() else - res = psb_vect_null_ + res = psb_dupl_null_ end if end function i_vect_get_dupl @@ -165,6 +167,31 @@ contains end if end subroutine i_vect_set_dupl + function i_vect_get_ncfs(x) result(res) + implicit none + class(psb_i_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function i_vect_get_ncfs + + subroutine i_vect_set_ncfs(x,val) + implicit none + class(psb_i_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine i_vect_set_ncfs + function i_vect_get_state(x) result(res) implicit none class(psb_i_vect_type), intent(in) :: x @@ -256,7 +283,6 @@ contains x%nrmv = val end subroutine i_vect_set_nrmv - function i_vect_is_remote_build(x) result(res) implicit none @@ -563,6 +589,7 @@ contains if (allocated(x%v)) then call x%v%asb(n,info,scratch=scratch) + call x%set_asb() end if end subroutine i_vect_asb @@ -677,6 +704,7 @@ contains if (allocated(x%v%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) call x%v%free(info) endif end if diff --git a/base/modules/serial/psb_l_base_vect_mod.F90 b/base/modules/serial/psb_l_base_vect_mod.F90 index 1df397b3..6059ff36 100644 --- a/base/modules/serial/psb_l_base_vect_mod.F90 +++ b/base/modules/serial/psb_l_base_vect_mod.F90 @@ -114,6 +114,7 @@ module psb_l_base_vect_mod procedure, pass(x) :: is_bld => l_base_is_bld procedure, pass(x) :: is_upd => l_base_is_upd procedure, pass(x) :: is_asb => l_base_is_asb + procedure, pass(x) :: base_cpy => l_base_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -620,7 +621,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -634,7 +635,9 @@ contains & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if + end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine l_base_asb_m @@ -701,7 +704,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -716,6 +719,8 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine l_base_asb_e @@ -997,6 +1002,24 @@ contains res = .true. end function l_base_is_sync + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine l_base_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(in) :: x + class(psb_l_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine l_base_cpy ! ! Size info. diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index 06afda3a..c1f6ca8f 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -64,6 +64,8 @@ module psb_l_vect_mod procedure, pass(x) :: asb => l_vect_asb procedure, pass(x) :: set_dupl => l_vect_set_dupl procedure, pass(x) :: get_dupl => l_vect_get_dupl + procedure, pass(x) :: set_ncfs => l_vect_set_ncfs + procedure, pass(x) :: get_ncfs => l_vect_get_ncfs procedure, pass(x) :: set_state => l_vect_set_state procedure, pass(x) :: set_null => l_vect_set_null procedure, pass(x) :: set_bld => l_vect_set_bld @@ -146,9 +148,9 @@ contains class(psb_l_vect_type), intent(in) :: x integer(psb_ipk_) :: res if (allocated(x%v)) then - res = x%v%get_state() + res = x%v%get_dupl() else - res = psb_vect_null_ + res = psb_dupl_null_ end if end function l_vect_get_dupl @@ -166,6 +168,31 @@ contains end if end subroutine l_vect_set_dupl + function l_vect_get_ncfs(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function l_vect_get_ncfs + + subroutine l_vect_set_ncfs(x,val) + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine l_vect_set_ncfs + function l_vect_get_state(x) result(res) implicit none class(psb_l_vect_type), intent(in) :: x @@ -257,7 +284,6 @@ contains x%nrmv = val end subroutine l_vect_set_nrmv - function l_vect_is_remote_build(x) result(res) implicit none @@ -564,6 +590,7 @@ contains if (allocated(x%v)) then call x%v%asb(n,info,scratch=scratch) + call x%set_asb() end if end subroutine l_vect_asb @@ -678,6 +705,7 @@ contains if (allocated(x%v%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) call x%v%free(info) endif end if diff --git a/base/modules/serial/psb_s_base_vect_mod.F90 b/base/modules/serial/psb_s_base_vect_mod.F90 index 488bfbe2..7bb3f5fe 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -115,6 +115,7 @@ module psb_s_base_vect_mod procedure, pass(x) :: is_bld => s_base_is_bld procedure, pass(x) :: is_upd => s_base_is_upd procedure, pass(x) :: is_asb => s_base_is_asb + procedure, pass(x) :: base_cpy => s_base_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -693,7 +694,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -707,7 +708,9 @@ contains & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if + end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine s_base_asb_m @@ -774,7 +777,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -789,6 +792,8 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine s_base_asb_e @@ -1070,6 +1075,24 @@ contains res = .true. end function s_base_is_sync + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine s_base_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine s_base_cpy ! ! Size info. diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 78105013..fab3fdb2 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -64,6 +64,8 @@ module psb_s_vect_mod procedure, pass(x) :: asb => s_vect_asb procedure, pass(x) :: set_dupl => s_vect_set_dupl procedure, pass(x) :: get_dupl => s_vect_get_dupl + procedure, pass(x) :: set_ncfs => s_vect_set_ncfs + procedure, pass(x) :: get_ncfs => s_vect_get_ncfs procedure, pass(x) :: set_state => s_vect_set_state procedure, pass(x) :: set_null => s_vect_set_null procedure, pass(x) :: set_bld => s_vect_set_bld @@ -207,9 +209,9 @@ contains class(psb_s_vect_type), intent(in) :: x integer(psb_ipk_) :: res if (allocated(x%v)) then - res = x%v%get_state() + res = x%v%get_dupl() else - res = psb_vect_null_ + res = psb_dupl_null_ end if end function s_vect_get_dupl @@ -227,6 +229,31 @@ contains end if end subroutine s_vect_set_dupl + function s_vect_get_ncfs(x) result(res) + implicit none + class(psb_s_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function s_vect_get_ncfs + + subroutine s_vect_set_ncfs(x,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine s_vect_set_ncfs + function s_vect_get_state(x) result(res) implicit none class(psb_s_vect_type), intent(in) :: x @@ -318,7 +345,6 @@ contains x%nrmv = val end subroutine s_vect_set_nrmv - function s_vect_is_remote_build(x) result(res) implicit none @@ -625,6 +651,7 @@ contains if (allocated(x%v)) then call x%v%asb(n,info,scratch=scratch) + call x%set_asb() end if end subroutine s_vect_asb @@ -739,6 +766,7 @@ contains if (allocated(x%v%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) call x%v%free(info) endif end if diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index fa7fb39a..3c7383e6 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -115,6 +115,7 @@ module psb_z_base_vect_mod procedure, pass(x) :: is_bld => z_base_is_bld procedure, pass(x) :: is_upd => z_base_is_upd procedure, pass(x) :: is_asb => z_base_is_asb + procedure, pass(x) :: base_cpy => z_base_cpy ! ! Sync: centerpiece of handling of external storage. ! Any derived class having extra storage upon sync @@ -686,7 +687,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -700,7 +701,9 @@ contains & call psb_realloc(n,x%v,info) if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') - end if + end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine z_base_asb_m @@ -767,7 +770,7 @@ contains end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) - else if (x%is_upd().or.scratch_) then + else if (x%is_upd().or.x%is_asb().or.scratch_) then if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) if (info /= 0) & @@ -782,6 +785,8 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') end if + call x%set_host() + call x%set_asb() call x%sync() end subroutine z_base_asb_e @@ -1063,6 +1068,24 @@ contains res = .true. end function z_base_is_sync + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine z_base_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine z_base_cpy ! ! Size info. diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 4820e794..9d1d49d5 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -64,6 +64,8 @@ module psb_z_vect_mod procedure, pass(x) :: asb => z_vect_asb procedure, pass(x) :: set_dupl => z_vect_set_dupl procedure, pass(x) :: get_dupl => z_vect_get_dupl + procedure, pass(x) :: set_ncfs => z_vect_set_ncfs + procedure, pass(x) :: get_ncfs => z_vect_get_ncfs procedure, pass(x) :: set_state => z_vect_set_state procedure, pass(x) :: set_null => z_vect_set_null procedure, pass(x) :: set_bld => z_vect_set_bld @@ -200,9 +202,9 @@ contains class(psb_z_vect_type), intent(in) :: x integer(psb_ipk_) :: res if (allocated(x%v)) then - res = x%v%get_state() + res = x%v%get_dupl() else - res = psb_vect_null_ + res = psb_dupl_null_ end if end function z_vect_get_dupl @@ -220,6 +222,31 @@ contains end if end subroutine z_vect_set_dupl + function z_vect_get_ncfs(x) result(res) + implicit none + class(psb_z_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function z_vect_get_ncfs + + subroutine z_vect_set_ncfs(x,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine z_vect_set_ncfs + function z_vect_get_state(x) result(res) implicit none class(psb_z_vect_type), intent(in) :: x @@ -311,7 +338,6 @@ contains x%nrmv = val end subroutine z_vect_set_nrmv - function z_vect_is_remote_build(x) result(res) implicit none @@ -618,6 +644,7 @@ contains if (allocated(x%v)) then call x%v%asb(n,info,scratch=scratch) + call x%set_asb() end if end subroutine z_vect_asb @@ -732,6 +759,7 @@ contains if (allocated(x%v%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) call x%v%free(info) endif end if diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index 9c31332b..85ccbf6a 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -95,8 +95,7 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode) goto 9999 endif - allocate(psb_c_base_vect_type :: x%v, stat=info) - if (info == 0) call x%all(nr,info) + call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 52c0ae90..a8ef4672 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -95,8 +95,7 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode) goto 9999 endif - allocate(psb_d_base_vect_type :: x%v, stat=info) - if (info == 0) call x%all(nr,info) + call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index d708e324..95558fe2 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -95,8 +95,7 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode) goto 9999 endif - allocate(psb_i_base_vect_type :: x%v, stat=info) - if (info == 0) call x%all(nr,info) + call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 index e89b4b15..8bb369c3 100644 --- a/base/tools/psb_lallc.f90 +++ b/base/tools/psb_lallc.f90 @@ -95,8 +95,7 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode) goto 9999 endif - allocate(psb_l_base_vect_type :: x%v, stat=info) - if (info == 0) call x%all(nr,info) + call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 143e032b..7e6649dd 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -95,8 +95,7 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode) goto 9999 endif - allocate(psb_s_base_vect_type :: x%v, stat=info) - if (info == 0) call x%all(nr,info) + call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index fa7518fa..96d567fc 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -95,8 +95,7 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode) goto 9999 endif - allocate(psb_z_base_vect_type :: x%v, stat=info) - if (info == 0) call x%all(nr,info) + call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)')