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

psblas3:

Browse Source 
base/tools/psb_c_map.f90
 base/tools/psb_d_map.f90
 base/tools/psb_s_map.f90
 base/tools/psb_z_map.f90

Fixed X2Y and Y2X pointer magic.
trunk
Salvatore Filippone 8 years ago
parent 8f5fd02e6a
commit 85da2dbd27
4 changed files with 184 additions and 112 deletions
Show Stats Download Patch File Download Diff File

70
base/tools/psb_c_map.f90
Unescape Escape View File

@ -147,7 +147,7 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
if (present(vty)) then if (present(vty)) then
pty => vty pty => vty
else else
call yt%bld(nc2,mold=x%v) call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
pty => yt pty => yt
end if end if
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
@ -178,13 +178,13 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
ptx => vtx ptx => vtx
pty => vty pty => vty
else else
call xt%bld(nc1,mold=x%v) call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call yt%bld(nc2,mold=y%v) call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
ptx => xt ptx => xt
pty => yt pty => yt
end if end if
call psb_geaxpby(cone,x,@XZERO,ptx,map%desc_X,info) call psb_geaxpby(cone,x,czero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work) if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%map_X2Y,ptx,czero,pty,info) if (info == psb_success_) call psb_csmm(cone,map%map_X2Y,ptx,czero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
@ -197,8 +197,10 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.present(vtx)) call xt%free(info) if (.not.(present(vtx).and.present(vty) )) then
if (.not.present(vty)) call yt%free(info) call xt%free(info)
call yt%free(info)
end if
end if end if
case default case default
@ -290,7 +292,7 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work)
end subroutine psb_c_map_Y2X end subroutine psb_c_map_Y2X
subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work) subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_c_map_Y2X_vect use psb_base_mod, psb_protect_name => psb_c_map_Y2X_vect
implicit none implicit none
type(psb_clinmap_type), intent(in) :: map type(psb_clinmap_type), intent(in) :: map
@ -298,8 +300,10 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
type(psb_c_vect_type), intent(inout) :: x,y type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:) complex(psb_spk_), optional :: work(:)
! type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
type(psb_c_vect_type) :: xt, yt ! Local
type(psb_c_vect_type), target :: xt, yt
type(psb_c_vect_type),pointer :: ptx, pty
complex(psb_spk_), allocatable :: xta(:), yta(:) complex(psb_spk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt & map_kind, nr, ictxt
@ -320,20 +324,25 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context() ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows() nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols() nc2 = map%p_desc_X%get_local_cols()
call yt%bld(nc2,mold=y%v) if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%map_Y2X,x,czero,yt,info) if (info == psb_success_) call psb_csmm(cone,map%map_Y2X,x,czero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
yta = yt%get_vect() yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
call yt%free(info) if (.not.present(vty)) call yt%free(info)
end if end if
case(psb_map_gen_linear_) case(psb_map_gen_linear_)
@ -343,26 +352,35 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols() nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows() nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols() nc2 = map%desc_X%get_local_cols()
call xt%bld(nc1,mold=x%v) if (present(vtx).and.present(vty)) then
call yt%bld(nc2,mold=y%v) ptx => vtx
xta = x%get_vect() pty => vty
call xt%set(xta(1:nr1)) else
call psb_geasb(xt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_X,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) call psb_geaxpby(cone,x,czero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_csmm(cone,map%map_Y2X,xt,czero,yt,info)
if ((info == psb_success_) .and. map%desc_X%is_repl()) then if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
yta = yt%get_vect() if (info == psb_success_) call psb_csmm(cone,map%map_Y2X,ptx,czero,pty,info)
if ((info == psb_success_) .and. map%desc_X%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.(present(vtx).and.present(vty) )) then
call xt%free(info) call xt%free(info)
call yt%free(info) call yt%free(info)
end if end if
end if
case default case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input' write(psb_err_unit,*) trim(name),' Invalid descriptor input'

70
base/tools/psb_d_map.f90
Unescape Escape View File

@ -147,7 +147,7 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
if (present(vty)) then if (present(vty)) then
pty => vty pty => vty
else else
call yt%bld(nc2,mold=x%v) call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
pty => yt pty => yt
end if end if
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
@ -178,13 +178,13 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
ptx => vtx ptx => vtx
pty => vty pty => vty
else else
call xt%bld(nc1,mold=x%v) call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call yt%bld(nc2,mold=y%v) call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
ptx => xt ptx => xt
pty => yt pty => yt
end if end if
call psb_geaxpby(done,x,@XZERO,ptx,map%desc_X,info) call psb_geaxpby(done,x,dzero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work) if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%map_X2Y,ptx,dzero,pty,info) if (info == psb_success_) call psb_csmm(done,map%map_X2Y,ptx,dzero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
@ -197,8 +197,10 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.present(vtx)) call xt%free(info) if (.not.(present(vtx).and.present(vty) )) then
if (.not.present(vty)) call yt%free(info) call xt%free(info)
call yt%free(info)
end if
end if end if
case default case default
@ -290,7 +292,7 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work)
end subroutine psb_d_map_Y2X end subroutine psb_d_map_Y2X
subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work) subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_d_map_Y2X_vect use psb_base_mod, psb_protect_name => psb_d_map_Y2X_vect
implicit none implicit none
type(psb_dlinmap_type), intent(in) :: map type(psb_dlinmap_type), intent(in) :: map
@ -298,8 +300,10 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
type(psb_d_vect_type), intent(inout) :: x,y type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:) real(psb_dpk_), optional :: work(:)
! type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
type(psb_d_vect_type) :: xt, yt ! Local
type(psb_d_vect_type), target :: xt, yt
type(psb_d_vect_type),pointer :: ptx, pty
real(psb_dpk_), allocatable :: xta(:), yta(:) real(psb_dpk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt & map_kind, nr, ictxt
@ -320,20 +324,25 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context() ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows() nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols() nc2 = map%p_desc_X%get_local_cols()
call yt%bld(nc2,mold=y%v) if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%map_Y2X,x,dzero,yt,info) if (info == psb_success_) call psb_csmm(done,map%map_Y2X,x,dzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
yta = yt%get_vect() yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
call yt%free(info) if (.not.present(vty)) call yt%free(info)
end if end if
case(psb_map_gen_linear_) case(psb_map_gen_linear_)
@ -343,26 +352,35 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols() nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows() nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols() nc2 = map%desc_X%get_local_cols()
call xt%bld(nc1,mold=x%v) if (present(vtx).and.present(vty)) then
call yt%bld(nc2,mold=y%v) ptx => vtx
xta = x%get_vect() pty => vty
call xt%set(xta(1:nr1)) else
call psb_geasb(xt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_X,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) call psb_geaxpby(done,x,dzero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_csmm(done,map%map_Y2X,xt,dzero,yt,info)
if ((info == psb_success_) .and. map%desc_X%is_repl()) then if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
yta = yt%get_vect() if (info == psb_success_) call psb_csmm(done,map%map_Y2X,ptx,dzero,pty,info)
if ((info == psb_success_) .and. map%desc_X%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.(present(vtx).and.present(vty) )) then
call xt%free(info) call xt%free(info)
call yt%free(info) call yt%free(info)
end if end if
end if
case default case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input' write(psb_err_unit,*) trim(name),' Invalid descriptor input'

70
base/tools/psb_s_map.f90
Unescape Escape View File

@ -147,7 +147,7 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
if (present(vty)) then if (present(vty)) then
pty => vty pty => vty
else else
call yt%bld(nc2,mold=x%v) call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
pty => yt pty => yt
end if end if
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
@ -178,13 +178,13 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
ptx => vtx ptx => vtx
pty => vty pty => vty
else else
call xt%bld(nc1,mold=x%v) call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call yt%bld(nc2,mold=y%v) call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
ptx => xt ptx => xt
pty => yt pty => yt
end if end if
call psb_geaxpby(sone,x,@XZERO,ptx,map%desc_X,info) call psb_geaxpby(sone,x,szero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work) if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%map_X2Y,ptx,szero,pty,info) if (info == psb_success_) call psb_csmm(sone,map%map_X2Y,ptx,szero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
@ -197,8 +197,10 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.present(vtx)) call xt%free(info) if (.not.(present(vtx).and.present(vty) )) then
if (.not.present(vty)) call yt%free(info) call xt%free(info)
call yt%free(info)
end if
end if end if
case default case default
@ -290,7 +292,7 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work)
end subroutine psb_s_map_Y2X end subroutine psb_s_map_Y2X
subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work) subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_s_map_Y2X_vect use psb_base_mod, psb_protect_name => psb_s_map_Y2X_vect
implicit none implicit none
type(psb_slinmap_type), intent(in) :: map type(psb_slinmap_type), intent(in) :: map
@ -298,8 +300,10 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
type(psb_s_vect_type), intent(inout) :: x,y type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:) real(psb_spk_), optional :: work(:)
! type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
type(psb_s_vect_type) :: xt, yt ! Local
type(psb_s_vect_type), target :: xt, yt
type(psb_s_vect_type),pointer :: ptx, pty
real(psb_spk_), allocatable :: xta(:), yta(:) real(psb_spk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt & map_kind, nr, ictxt
@ -320,20 +324,25 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context() ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows() nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols() nc2 = map%p_desc_X%get_local_cols()
call yt%bld(nc2,mold=y%v) if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%map_Y2X,x,szero,yt,info) if (info == psb_success_) call psb_csmm(sone,map%map_Y2X,x,szero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
yta = yt%get_vect() yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
call yt%free(info) if (.not.present(vty)) call yt%free(info)
end if end if
case(psb_map_gen_linear_) case(psb_map_gen_linear_)
@ -343,26 +352,35 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols() nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows() nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols() nc2 = map%desc_X%get_local_cols()
call xt%bld(nc1,mold=x%v) if (present(vtx).and.present(vty)) then
call yt%bld(nc2,mold=y%v) ptx => vtx
xta = x%get_vect() pty => vty
call xt%set(xta(1:nr1)) else
call psb_geasb(xt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_X,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) call psb_geaxpby(sone,x,szero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_csmm(sone,map%map_Y2X,xt,szero,yt,info)
if ((info == psb_success_) .and. map%desc_X%is_repl()) then if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
yta = yt%get_vect() if (info == psb_success_) call psb_csmm(sone,map%map_Y2X,ptx,szero,pty,info)
if ((info == psb_success_) .and. map%desc_X%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.(present(vtx).and.present(vty) )) then
call xt%free(info) call xt%free(info)
call yt%free(info) call yt%free(info)
end if end if
end if
case default case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input' write(psb_err_unit,*) trim(name),' Invalid descriptor input'

70
base/tools/psb_z_map.f90
Unescape Escape View File

@ -147,7 +147,7 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
if (present(vty)) then if (present(vty)) then
pty => vty pty => vty
else else
call yt%bld(nc2,mold=x%v) call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
pty => yt pty => yt
end if end if
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
@ -178,13 +178,13 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
ptx => vtx ptx => vtx
pty => vty pty => vty
else else
call xt%bld(nc1,mold=x%v) call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call yt%bld(nc2,mold=y%v) call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
ptx => xt ptx => xt
pty => yt pty => yt
end if end if
call psb_geaxpby(zone,x,@XZERO,ptx,map%desc_X,info) call psb_geaxpby(zone,x,zzero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work) if (info == psb_success_) call psb_halo(ptx,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%map_X2Y,ptx,zzero,pty,info) if (info == psb_success_) call psb_csmm(zone,map%map_X2Y,ptx,zzero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
@ -197,8 +197,10 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.present(vtx)) call xt%free(info) if (.not.(present(vtx).and.present(vty) )) then
if (.not.present(vty)) call yt%free(info) call xt%free(info)
call yt%free(info)
end if
end if end if
case default case default
@ -290,7 +292,7 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work)
end subroutine psb_z_map_Y2X end subroutine psb_z_map_Y2X
subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work) subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_z_map_Y2X_vect use psb_base_mod, psb_protect_name => psb_z_map_Y2X_vect
implicit none implicit none
type(psb_zlinmap_type), intent(in) :: map type(psb_zlinmap_type), intent(in) :: map
@ -298,8 +300,10 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
type(psb_z_vect_type), intent(inout) :: x,y type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:) complex(psb_dpk_), optional :: work(:)
! type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
type(psb_z_vect_type) :: xt, yt ! Local
type(psb_z_vect_type), target :: xt, yt
type(psb_z_vect_type),pointer :: ptx, pty
complex(psb_dpk_), allocatable :: xta(:), yta(:) complex(psb_dpk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt & map_kind, nr, ictxt
@ -320,20 +324,25 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context() ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows() nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols() nc2 = map%p_desc_X%get_local_cols()
call yt%bld(nc2,mold=y%v) if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%map_Y2X,x,zzero,yt,info) if (info == psb_success_) call psb_csmm(zone,map%map_Y2X,x,zzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
yta = yt%get_vect() yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
call yt%free(info) if (.not.present(vty)) call yt%free(info)
end if end if
case(psb_map_gen_linear_) case(psb_map_gen_linear_)
@ -343,26 +352,35 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols() nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows() nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols() nc2 = map%desc_X%get_local_cols()
call xt%bld(nc1,mold=x%v) if (present(vtx).and.present(vty)) then
call yt%bld(nc2,mold=y%v) ptx => vtx
xta = x%get_vect() pty => vty
call xt%set(xta(1:nr1)) else
call psb_geasb(xt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_X,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) call psb_geaxpby(zone,x,zzero,ptx,map%desc_X,info)
if (info == psb_success_) call psb_csmm(zone,map%map_Y2X,xt,zzero,yt,info)
if ((info == psb_success_) .and. map%desc_X%is_repl()) then if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
yta = yt%get_vect() if (info == psb_success_) call psb_csmm(zone,map%map_Y2X,ptx,zzero,pty,info)
if ((info == psb_success_) .and. map%desc_X%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2)) call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta) call pty%set(yta)
end if end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info /= psb_success_) then if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1 info = -1
else else
if (.not.(present(vtx).and.present(vty) )) then
call xt%free(info) call xt%free(info)
call yt%free(info) call yt%free(info)
end if end if
end if
case default case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input' write(psb_err_unit,*) trim(name),' Invalid descriptor input'

Write Preview
Loading…
Cancel
Save