diff --git a/base/modules/Makefile b/base/modules/Makefile index 265e2bbc..7096f7e9 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -109,7 +109,7 @@ psb_s_serial_mod.o psb_d_serial_mod.o psb_c_serial_mod.o psb_z_serial_mod.o: psb psb_serial_mod.o: psb_s_serial_mod.o psb_d_serial_mod.o psb_c_serial_mod.o psb_z_serial_mod.o psb_i_vect_mod.o: psb_i_base_vect_mod.o psb_s_vect_mod.o: psb_s_base_vect_mod.o -psb_d_vect_mod.o: psb_d_base_vect_mod.o +psb_d_vect_mod.o: psb_d_base_vect_mod.o psb_i_vect_mod.o psb_c_vect_mod.o: psb_c_base_vect_mod.o psb_z_vect_mod.o: psb_z_base_vect_mod.o psb_tools_mod.o: psb_cd_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\ diff --git a/base/modules/psb_d_base_vect_mod.f90 b/base/modules/psb_d_base_vect_mod.f90 index 98cdac60..dbc037a6 100644 --- a/base/modules/psb_d_base_vect_mod.f90 +++ b/base/modules/psb_d_base_vect_mod.f90 @@ -76,7 +76,9 @@ module psb_d_base_vect_mod ! Assembly does almost nothing here, but is important ! in derived classes. ! - procedure, pass(x) :: ins => d_base_ins + procedure, pass(x) :: ins_a => d_base_ins_a + procedure, pass(x) :: ins_v => d_base_ins_v + generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => d_base_zero procedure, pass(x) :: asb => d_base_asb procedure, pass(x) :: free => d_base_free @@ -296,7 +298,7 @@ contains !! \param info return code !! ! - subroutine d_base_ins(n,irl,val,dupl,x,info) + subroutine d_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod implicit none class(psb_d_base_vect_type), intent(inout) :: x @@ -343,8 +345,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 @@ -352,7 +354,33 @@ contains return end if - end subroutine d_base_ins + end subroutine d_base_ins_a + + subroutine d_base_ins_v(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_d_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz + + info = 0 + if (psb_errstatus_fatal()) return + + call irl%sync() + call val%sync() + call x%ins(n,irl%v,val%v,dupl,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine d_base_ins_v + ! !> Function base_zero diff --git a/base/modules/psb_d_tools_mod.f90 b/base/modules/psb_d_tools_mod.f90 index 717cc56a..5a2d2ecc 100644 --- a/base/modules/psb_d_tools_mod.f90 +++ b/base/modules/psb_d_tools_mod.f90 @@ -31,7 +31,7 @@ !!$ Module psb_d_tools_mod use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_ - use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type + use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type, psb_i_vect_type use psb_d_mat_mod, only : psb_dspmat_type, psb_d_base_sparse_mat interface psb_geall @@ -206,6 +206,19 @@ Module psb_d_tools_mod integer(psb_ipk_), optional, intent(in) :: dupl logical, intent(in), optional :: local end subroutine psb_dins_vect + subroutine psb_dins_vect_v(m,irw,val,x,desc_a,info,dupl,local) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_d_base_vect_type, psb_d_vect_type, psb_i_vect_type, & + & psb_dspmat_type, psb_d_base_sparse_mat + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_d_vect_type), intent(inout) :: x + type(psb_i_vect_type), intent(inout) :: irw + type(psb_d_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_dins_vect_v subroutine psb_dins_vect_r2(m,irw,val,x,desc_a,info,dupl,local) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_base_vect_type, psb_d_vect_type, & diff --git a/base/modules/psb_d_vect_mod.F90 b/base/modules/psb_d_vect_mod.F90 index f4709b67..8affad6f 100644 --- a/base/modules/psb_d_vect_mod.F90 +++ b/base/modules/psb_d_vect_mod.F90 @@ -40,6 +40,7 @@ module psb_d_vect_mod use psb_d_base_vect_mod + use psb_i_vect_mod type psb_d_vect_type class(psb_d_base_vect_type), allocatable :: v @@ -76,7 +77,9 @@ module psb_d_vect_mod procedure, pass(y) :: sctb => d_vect_sctb generic, public :: sct => sctb procedure, pass(x) :: free => d_vect_free - procedure, pass(x) :: ins => d_vect_ins + procedure, pass(x) :: ins_a => d_vect_ins_a + procedure, pass(x) :: ins_v => d_vect_ins_v + generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => d_vect_bld_x procedure, pass(x) :: bld_n => d_vect_bld_n generic, public :: bld => bld_x, bld_n @@ -619,7 +622,7 @@ contains end subroutine d_vect_free - subroutine d_vect_ins(n,irl,val,dupl,x,info) + subroutine d_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod implicit none class(psb_d_vect_type), intent(inout) :: x @@ -635,10 +638,31 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - - end subroutine d_vect_ins + + end subroutine d_vect_ins_a + + subroutine d_vect_ins_v(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + class(psb_i_vect_type), intent(inout) :: irl + class(psb_d_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i + + info = 0 + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + info = psb_err_invalid_vect_state_ + return + end if + + call x%v%ins(n,irl%v,val%v,dupl,info) + + end subroutine d_vect_ins_v subroutine d_vect_cnv(x,mold) diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 385f0575..f4900b81 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -304,6 +304,123 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) end subroutine psb_dins_vect + +subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_dins_vect_v + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + type(psb_i_vect_type), intent(inout) :: irw + type(psb_d_vect_type), intent(inout) :: val + type(psb_d_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + real(psb_dpk_), allocatable :: lval(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_dinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + call x%ins(m,irw,val,dupl_,info) + else + irl = irw%get_vect() + lval = val%get_vect() + call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.) + call x%ins(m,irl,lval,dupl_,info) + end if + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_dins_vect_v + subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_dins_vect_r2 use psi_mod diff --git a/base/tools/psb_dspins.f90 b/base/tools/psb_dspins.f90 index 7c6b4d17..f698026d 100644 --- a/base/tools/psb_dspins.f90 +++ b/base/tools/psb_dspins.f90 @@ -80,11 +80,13 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_info(ictxt, me, np) if (nz < 0) then + write(0,*)name, ' NZ ',nz info = 1111 call psb_errpush(info,name) goto 9999 end if if (size(ia) < nz) then + write(0,*) name,' IA ',size(ia),nz info = 1111 call psb_errpush(info,name) goto 9999 @@ -92,16 +94,19 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) if (size(ja) < nz) then info = 1111 + write(0,*) name,' jA ',size(ja),nz call psb_errpush(info,name) goto 9999 end if if (size(val) < nz) then info = 1111 + write(0,*) name,' VAL ',size(val),nz call psb_errpush(info,name) goto 9999 end if - if (nz == 0) return + if (nz == 0) return + if (present(rebuild)) then rebuild_ = rebuild else @@ -130,7 +135,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) end if call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.) - call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0)) + if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0)) if (info /= psb_success_) then ierr(1) = info @@ -180,9 +185,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) end if call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info) - call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info) + if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info) t2 = psb_Wtime() - call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) t3=psb_wtime() tcnv=t2-t1 tcsput=t3-t2