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/modules/psb_c_base_vect_mod.f90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_z_base_vect_mod.f90
 base/tools/psb_c_map.f90
 base/tools/psb_d_map.f90
 base/tools/psb_s_map.f90
 base/tools/psb_z_map.f90
 prec/psb_c_bjacprec.f90
 prec/psb_d_bjacprec.f90
 prec/psb_s_bjacprec.f90
 prec/psb_z_bjacprec.f90

Fixes for performance tuning of _vect (from MLD).
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent c95518cc17
commit f7cbd59695
12 changed files with 200 additions and 167 deletions
Show Stats Download Patch File Download Diff File

2
base/modules/psb_c_base_vect_mod.f90
Unescape Escape View File

@ -71,10 +71,12 @@ contains
subroutine c_base_bld_n(x,n)
use psb_realloc_mod
integer, intent(in) :: n
class(psb_c_base_vect_type), intent(inout) :: x
integer :: info
call psb_realloc(n,x%v,info)
call x%asb(n,info)
end subroutine c_base_bld_n

23
base/modules/psb_d_base_vect_mod.f90
Unescape Escape View File

@ -71,10 +71,12 @@ contains
subroutine d_base_bld_n(x,n)
use psb_realloc_mod
integer, intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
integer :: info
call psb_realloc(n,x%v,info)
call x%asb(n,info)
end subroutine d_base_bld_n
@ -218,15 +220,24 @@ contains
end subroutine d_base_axpby_a
subroutine d_base_mlt_v(x, y, info)
subroutine d_base_mlt_v(x, y, info, xconj)
use psi_serial_mod
use psb_string_mod
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
integer :: i, n
class(psb_d_base_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, intent(in), optional :: xconj
integer :: i, n
character :: xconj_
info = 0
if (present(xconj)) then
xconj_ = (psb_toupper(xconj))
else
xconj_ = 'N'
end if
select type(xx => x)
type is (psb_d_base_vect_type)
n = min(size(y%v), size(xx%v))

2
base/modules/psb_s_base_vect_mod.f90
Unescape Escape View File

@ -71,10 +71,12 @@ contains
subroutine s_base_bld_n(x,n)
use psb_realloc_mod
integer, intent(in) :: n
class(psb_s_base_vect_type), intent(inout) :: x
integer :: info
call psb_realloc(n,x%v,info)
call x%asb(n,info)
end subroutine s_base_bld_n

115
base/modules/psb_z_base_vect_mod.f90
Unescape Escape View File

@ -71,10 +71,12 @@ contains
subroutine z_base_bld_n(x,n)
use psb_realloc_mod
integer, intent(in) :: n
class(psb_z_base_vect_type), intent(inout) :: x
integer :: info
call psb_realloc(n,x%v,info)
call x%asb(n,info)
end subroutine z_base_bld_n
@ -219,41 +221,72 @@ contains
end subroutine z_base_axpby_a
subroutine z_base_mlt_v(x, y, info)
subroutine z_base_mlt_v(x, y, info, xconj)
use psi_serial_mod
use psb_string_mod
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
integer :: i, n
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, intent(in), optional :: xconj
integer :: i, n
character :: xconj_
info = 0
if (present(xconj)) then
xconj_ = (psb_toupper(xconj))
else
xconj_ = 'N'
end if
select type(xx => x)
type is (psb_z_base_vect_type)
n = min(size(y%v), size(xx%v))
do i=1, n
y%v(i) = y%v(i)*xx%v(i)
end do
select case (xconj_)
case ('C')
do i=1, n
y%v(i) = y%v(i)*conjg(xx%v(i))
end do
case default
do i=1, n
y%v(i) = y%v(i)*xx%v(i)
end do
end select
class default
call y%mlt(x%v,info)
call y%mlt(x%v,info,xconj)
end select
end subroutine z_base_mlt_v
subroutine z_base_mlt_a(x, y, info)
subroutine z_base_mlt_a(x, y, info, xconj)
use psi_serial_mod
use psb_string_mod
implicit none
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, intent(in), optional :: xconj
character :: xconj_
integer :: i, n
info = 0
if (present(xconj)) then
xconj_ = (psb_toupper(xconj))
else
xconj_ = 'N'
end if
n = min(size(y%v), size(x))
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
select case (xconj_)
case ('C')
do i=1, n
y%v(i) = y%v(i)*conjg(x(i))
end do
case default
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
end select
end subroutine z_base_mlt_a
@ -325,7 +358,7 @@ contains
end if
end subroutine z_base_mlt_a_2
subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,xconj,yconj)
use psi_serial_mod
use psb_string_mod
implicit none
@ -334,34 +367,35 @@ contains
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: conjgx, conjgy
character(len=1), intent(in), optional :: xconj, yconj
integer :: i, n
info = 0
if (present(conjgx)) then
if (psb_toupper(conjgx)=='C') x%v=conjg(x%v)
if (present(xconj)) then
if (psb_toupper(xconj)=='C') x%v=conjg(x%v)
end if
if (present(conjgy)) then
if (psb_toupper(conjgy)=='C') y%v=conjg(y%v)
if (present(yconj)) then
if (psb_toupper(yconj)=='C') y%v=conjg(y%v)
end if
call z%mlt(alpha,x%v,y%v,beta,info)
if (present(conjgx)) then
if (psb_toupper(conjgx)=='C') x%v=conjg(x%v)
if (present(xconj)) then
if (psb_toupper(xconj)=='C') x%v=conjg(x%v)
end if
if (present(conjgy)) then
if (psb_toupper(conjgy)=='C') y%v=conjg(y%v)
if (present(yconj)) then
if (psb_toupper(yconj)=='C') y%v=conjg(y%v)
end if
end subroutine z_base_mlt_v_2
subroutine z_base_mlt_av(alpha,x,y,beta,z,info)
subroutine z_base_mlt_av(alpha,x,y,beta,z,info,xconj,yconj)
use psi_serial_mod
implicit none
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: xconj, yconj
integer :: i, n
info = 0
@ -370,19 +404,20 @@ contains
end subroutine z_base_mlt_av
subroutine z_base_mlt_va(alpha,x,y,beta,z,info)
subroutine z_base_mlt_va(alpha,x,y,beta,z,info,xconj,yconj)
use psi_serial_mod
implicit none
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: y(:)
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: y(:)
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: xconj, yconj
integer :: i, n
info = 0
call z%mlt(alpha,y,x,beta,info)
call z%mlt(alpha,y,x,beta,info,xconj=yconj,yconj=xconj)
end subroutine z_base_mlt_va

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

@ -103,7 +103,8 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input'
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
& map_kind, psb_map_aggr_, psb_map_gen_linear_
info = 1
return
end select
@ -141,11 +142,10 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call yt%bld(nc2,mold=x%v)
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%map_X2Y,x,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then
if ((info == psb_success_) .and. map%p_desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -155,7 +155,7 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -165,15 +165,14 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work)
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
call psb_geall(xt,map%p_desc_X,info)
call psb_geasb(xt,map%p_desc_X,info,mold=x%v)
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%map_X2Y,xt,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then
if ((info == psb_success_) .and. map%desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -183,9 +182,9 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
@ -306,11 +305,10 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call yt%bld(nc2,mold=y%v)
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_) .and. psb_is_repl_desc(map%p_desc_X)) then
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -320,7 +318,7 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -329,18 +327,14 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
call psb_geall(xt,map%p_desc_Y,info)
call psb_geasb(xt,map%p_desc_Y,info,mold=x%v)
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%map_Y2X,xt,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then
if ((info == psb_success_) .and. map%desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -351,8 +345,8 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work)
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input'

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

@ -141,11 +141,10 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call yt%bld(nc2,mold=x%v)
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%map_X2Y,x,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then
if ((info == psb_success_) .and. map%p_desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -155,7 +154,7 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -164,16 +163,15 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
call psb_geall(xt,map%p_desc_X,info)
call psb_geasb(xt,map%p_desc_X,info,mold=x%v)
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%map_X2Y,xt,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then
if ((info == psb_success_) .and. map%desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -184,8 +182,8 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
@ -306,11 +304,10 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call yt%bld(nc2,mold=y%v)
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_) .and. psb_is_repl_desc(map%p_desc_X)) then
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -320,7 +317,7 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -329,17 +326,14 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
call psb_geall(xt,map%p_desc_Y,info)
call psb_geasb(xt,map%p_desc_Y,info,mold=x%v)
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%map_Y2X,xt,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then
if ((info == psb_success_) .and. map%desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -350,8 +344,8 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input'

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

@ -141,11 +141,10 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call yt%bld(nc2,mold=x%v)
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%map_X2Y,x,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then
if ((info == psb_success_) .and. map%p_desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -155,7 +154,7 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -165,15 +164,14 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work)
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
call psb_geall(xt,map%p_desc_X,info)
call psb_geasb(xt,map%p_desc_X,info,mold=x%v)
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%map_X2Y,xt,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then
if ((info == psb_success_) .and. map%desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -183,9 +181,9 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
@ -306,11 +304,10 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call yt%bld(nc2,mold=y%v)
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_) .and. psb_is_repl_desc(map%p_desc_X)) then
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -320,7 +317,7 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -329,18 +326,14 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
call psb_geall(xt,map%p_desc_Y,info)
call psb_geasb(xt,map%p_desc_Y,info,mold=x%v)
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%map_Y2X,xt,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then
if ((info == psb_success_) .and. map%desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -351,8 +344,8 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work)
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input'

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

@ -103,7 +103,8 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input'
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
& map_kind, psb_map_aggr_, psb_map_gen_linear_
info = 1
return
end select
@ -140,11 +141,10 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call yt%bld(nc2,mold=x%v)
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%map_X2Y,x,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then
if ((info == psb_success_) .and. map%p_desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -154,7 +154,7 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -164,15 +164,14 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work)
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
call psb_geall(xt,map%p_desc_X,info)
call psb_geasb(xt,map%p_desc_X,info,mold=x%v)
call psb_geall(yt,map%p_desc_Y,info)
call psb_geasb(yt,map%p_desc_Y,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%map_X2Y,xt,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then
if ((info == psb_success_) .and. map%desc_Y%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -182,9 +181,9 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input', &
@ -305,11 +304,10 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call yt%bld(nc2,mold=y%v)
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_) .and. psb_is_repl_desc(map%p_desc_X)) then
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -319,7 +317,7 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
end if
call psb_gefree(yt,map%p_desc_Y,info)
call yt%free(info)
case(psb_map_gen_linear_)
@ -328,18 +326,14 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
call psb_geall(xt,map%p_desc_Y,info)
call psb_geasb(xt,map%p_desc_Y,info,mold=x%v)
call psb_geall(yt,map%p_desc_X,info)
call psb_geasb(yt,map%p_desc_X,info,mold=y%v)
call xt%bld(nc1,mold=x%v)
call yt%bld(nc2,mold=y%v)
xta = x
call xt%set(xta(1:nr1))
if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%map_Y2X,xt,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then
if ((info == psb_success_) .and. map%desc_X%is_repl()) then
yta = yt
call psb_sum(ictxt,yta(1:nr2))
call yt%set(yta)
@ -350,8 +344,8 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work)
info = -1
end if
call psb_gefree(xt,map%p_desc_Y,info)
call psb_gefree(yt,map%p_desc_Y,info)
call xt%free(info)
call yt%free(info)
case default
write(psb_err_unit,*) trim(name),' Invalid descriptor input'

5
prec/psb_c_bjacprec.f90
Unescape Escape View File

@ -114,7 +114,7 @@ contains
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call wv%bld(n_col)
call wv%bld(n_col,mold=x%v)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
@ -155,8 +155,9 @@ contains
goto 9999
end select
!!$ call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call wv%free(info)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

14
prec/psb_d_bjacprec.f90
Unescape Escape View File

@ -114,7 +114,7 @@ contains
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call wv%bld(n_col)
call wv%bld(n_col,mold=x%v)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
@ -127,7 +127,14 @@ contains
& beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
case('T','C')
case('T')
call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux)
if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,&
& beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case('C')
call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux)
if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,&
@ -147,7 +154,7 @@ contains
goto 9999
end select
!!$ call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
@ -291,6 +298,7 @@ contains
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call wv%free(info)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

14
prec/psb_s_bjacprec.f90
Unescape Escape View File

@ -115,7 +115,7 @@ contains
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call wv%bld(n_col)
call wv%bld(n_col,mold=x%v)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
@ -128,7 +128,14 @@ contains
& beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
case('T','C')
case('T')
call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux)
if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,&
& beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case('C')
call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux)
if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,&
@ -148,8 +155,9 @@ contains
goto 9999
end select
!!$ call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call wv%free(info)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

15
prec/psb_z_bjacprec.f90
Unescape Escape View File

@ -114,7 +114,7 @@ contains
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call wv%bld(n_col)
call wv%bld(n_col,mold=x%v)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
@ -155,8 +155,9 @@ contains
goto 9999
end select
!!$ call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
call wv%free(info)
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
@ -233,16 +234,6 @@ contains
call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/))
goto 9999
end if
!!$ if (.not.allocated(prec%d)) then
!!$ info = 1124
!!$ call psb_errpush(info,name,a_err="preconditioner: D")
!!$ goto 9999
!!$ end if
!!$ if (size(prec%d) < n_row) then
!!$ info = 1124
!!$ call psb_errpush(info,name,a_err="preconditioner: D")
!!$ goto 9999
!!$ end if
if (n_col <= size(work)) then

Write Preview
Loading…
Cancel
Save