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

New linmap internal structure.

Browse Source
merge-paraggr
Salvatore Filippone 6 years ago
parent 300762ed29
commit fd8ce4f3de
9 changed files with 668 additions and 631 deletions
Show Stats Download Patch File Download Diff File

55
base/modules/comm/psb_base_linmap_mod.f90
Unescape Escape View File

@ -33,7 +33,8 @@
!
! package: psb_linmap_type_mod
! Defines data types for mapping between vectors belonging
! to different spaces.
! to different spaces U and V.
! As used in MLD2P4, U is the fine space and V is the coarse space.
!
module psb_base_linmap_mod
use psb_const_mod
@ -43,8 +44,8 @@ module psb_base_linmap_mod
type psb_base_linmap_type
integer(psb_ipk_) :: kind
integer(psb_lpk_), allocatable :: iaggr(:), naggr(:)
type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null()
type(psb_desc_type) :: desc_X, desc_Y
type(psb_desc_type), pointer :: p_desc_U=>null(), p_desc_V=>null()
type(psb_desc_type) :: desc_U, desc_V
contains
procedure, pass(map) :: sizeof => base_map_sizeof
procedure, pass(map) :: is_ok => base_is_ok
@ -93,11 +94,11 @@ contains
select case(map%get_kind())
case (psb_map_aggr_)
if (.not.associated(map%p_desc_X)) return
if (.not.associated(map%p_desc_Y)) return
res = map%p_desc_X%is_ok().and.map%p_desc_Y%is_ok()
if (.not.associated(map%p_desc_U)) return
if (.not.associated(map%p_desc_V)) return
res = map%p_desc_U%is_ok().and.map%p_desc_V%is_ok()
case(psb_map_gen_linear_)
res = map%desc_X%is_ok().and.map%desc_Y%is_ok()
res = map%desc_U%is_ok().and.map%desc_V%is_ok()
end select
end function base_is_ok
@ -111,11 +112,11 @@ contains
select case(map%get_kind())
case (psb_map_aggr_)
if (.not.associated(map%p_desc_X)) return
if (.not.associated(map%p_desc_Y)) return
res = map%p_desc_X%is_asb().and.map%p_desc_Y%is_asb()
if (.not.associated(map%p_desc_U)) return
if (.not.associated(map%p_desc_V)) return
res = map%p_desc_U%is_asb().and.map%p_desc_V%is_asb()
case(psb_map_gen_linear_)
res = map%desc_X%is_asb().and.map%desc_Y%is_asb()
res = map%desc_U%is_asb().and.map%desc_V%is_asb()
end select
end function base_is_asb
@ -131,8 +132,8 @@ contains
& val = val + psb_sizeof_lp*size(map%iaggr)
if (allocated(map%naggr)) &
& val = val + psb_sizeof_lp*size(map%naggr)
val = val + map%desc_X%sizeof()
val = val + map%desc_Y%sizeof()
val = val + map%desc_U%sizeof()
val = val + map%desc_V%sizeof()
end function base_map_sizeof
@ -147,12 +148,12 @@ contains
mapout%kind = mapin%kind
call psb_move_alloc(mapin%iaggr,mapout%iaggr,info)
call psb_move_alloc(mapin%naggr,mapout%naggr,info)
mapout%p_desc_X => mapin%p_desc_X
mapin%p_desc_X => null()
mapout%p_desc_Y => mapin%p_desc_Y
mapin%p_desc_Y => null()
call psb_move_alloc(mapin%desc_X,mapout%desc_X,info)
call psb_move_alloc(mapin%desc_Y,mapout%desc_Y,info)
mapout%p_desc_U => mapin%p_desc_U
mapin%p_desc_U => null()
mapout%p_desc_V => mapin%p_desc_V
mapin%p_desc_V => null()
call psb_move_alloc(mapin%desc_U,mapout%desc_U,info)
call psb_move_alloc(mapin%desc_V,mapout%desc_V,info)
end subroutine psb_base_linmap_transfer
@ -169,10 +170,10 @@ contains
mapout%kind = map%kind
call psb_safe_ab_cpy(map%iaggr,mapout%iaggr,info)
call psb_safe_ab_cpy(map%naggr,mapout%naggr,info)
mapout%p_desc_X => map%p_desc_X
mapout%p_desc_Y => map%p_desc_Y
call map%desc_X%clone(mapout%desc_X,info)
call map%desc_Y%clone(mapout%desc_Y,info)
mapout%p_desc_U => map%p_desc_U
mapout%p_desc_V => map%p_desc_V
call map%desc_U%clone(mapout%desc_U,info)
call map%desc_V%clone(mapout%desc_V,info)
end subroutine base_clone
@ -186,10 +187,10 @@ contains
& deallocate(map%iaggr,stat=info)
if (allocated(map%naggr)) &
& deallocate(map%naggr,stat=info)
map%p_desc_X => null()
map%p_desc_Y => null()
if (map%desc_X%is_ok()) call map%desc_X%free(info)
if (map%desc_Y%is_ok()) call map%desc_Y%free(info)
map%p_desc_U => null()
map%p_desc_V => null()
if (map%desc_U%is_ok()) call map%desc_U%free(info)
if (map%desc_V%is_ok()) call map%desc_V%free(info)
end subroutine base_free

85
base/modules/comm/psb_c_linmap_mod.f90
Unescape Escape View File

@ -44,8 +44,16 @@ module psb_c_linmap_mod
type, extends(psb_base_linmap_type) :: psb_clinmap_type
type(psb_cspmat_type) :: map_X2Y, map_Y2X
type(psb_cspmat_type) :: mat_U2V, mat_V2U
contains
procedure, pass(map) :: map_U2V_a => psb_c_map_U2V_a
procedure, pass(map) :: map_U2V_v => psb_c_map_U2V_v
generic, public :: map_U2V => map_U2V_a, map_U2V_v
procedure, pass(map) :: map_V2U_a => psb_c_map_V2U_a
procedure, pass(map) :: map_V2U_v => psb_c_map_V2U_v
generic, public :: map_V2U => map_V2U_a, map_V2U_v
procedure, pass(map) :: sizeof => c_map_sizeof
procedure, pass(map) :: is_asb => c_is_asb
procedure, pass(map) :: free => c_free
@ -54,52 +62,52 @@ module psb_c_linmap_mod
end type psb_clinmap_type
interface psb_map_X2Y
subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work)
interface psb_map_U2V
subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_spk_, psb_clinmap_type
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine psb_c_map_X2Y
subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_c_map_U2V_a
subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_c_vect_mod, only : psb_c_vect_type
import :: psb_ipk_, psb_spk_, psb_clinmap_type
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_c_map_X2Y_vect
end subroutine psb_c_map_U2V_v
end interface
interface psb_map_Y2X
subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work)
interface psb_map_V2U
subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_spk_, psb_clinmap_type
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine psb_c_map_Y2X
subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_c_map_V2U_a
subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_c_vect_mod, only : psb_c_vect_type
import :: psb_ipk_, psb_spk_, psb_clinmap_type
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_c_map_Y2X_vect
end subroutine psb_c_map_V2U_v
end interface
@ -116,13 +124,13 @@ module psb_c_linmap_mod
end interface
interface psb_linmap
function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr)
function psb_c_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr)
use psb_c_mat_mod, only : psb_cspmat_type
import :: psb_ipk_, psb_clinmap_type, psb_desc_type, psb_lpk_
implicit none
type(psb_clinmap_type) :: psb_c_linmap
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_cspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_cspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
end function psb_c_linmap
@ -142,8 +150,8 @@ contains
integer(psb_epk_) :: val
val = map%psb_base_linmap_type%sizeof()
val = val + map%map_X2Y%sizeof()
val = val + map%map_Y2X%sizeof()
val = val + map%mat_U2V%sizeof()
val = val + map%mat_V2U%sizeof()
end function c_map_sizeof
@ -154,7 +162,7 @@ contains
logical :: val
val = map%psb_base_linmap_type%is_asb() .and. &
& map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb()
& map%mat_U2V%is_asb() .and.map%mat_V2U%is_asb()
end function c_is_asb
@ -167,26 +175,27 @@ contains
class(psb_c_base_sparse_mat), intent(in), optional :: mold
class(psb_i_base_vect_type), intent(in), optional :: imold
if (map%map_X2Y%is_asb())&
& call map%map_X2Y%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%map_Y2X%is_asb())&
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
if (map%mat_U2V%is_asb())&
& call map%mat_U2V%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%mat_V2U%is_asb())&
& call map%mat_V2U%cscnv(info,type=type,mold=mold)
if (present(imold)) then
call map%desc_X%cnv(mold=imold)
call map%desc_Y%cnv(mold=imold)
call map%desc_U%cnv(mold=imold)
call map%desc_V%cnv(mold=imold)
end if
end subroutine psb_c_map_cscnv
subroutine psb_c_linmap_sub(out_map,map_kind,desc_X, desc_Y,&
& map_X2Y, map_Y2X,iaggr,naggr)
subroutine psb_c_linmap_sub(out_map,map_kind,desc_U, desc_V,&
& mat_U2V, mat_V2U,iaggr,naggr)
use psb_c_mat_mod
implicit none
type(psb_clinmap_type), intent(out) :: out_map
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_cspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_cspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr)
out_map = psb_linmap(map_kind,desc_U,desc_V,mat_U2V,mat_V2U,iaggr,naggr)
end subroutine psb_c_linmap_sub
subroutine psb_clinmap_transfer(mapin,mapout,info)
@ -197,8 +206,8 @@ contains
call psb_move_alloc(mapin%psb_base_linmap_type, &
& mapout%psb_base_linmap_type,info)
call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info)
call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info)
call psb_move_alloc(mapin%mat_U2V,mapout%mat_U2V,info)
call psb_move_alloc(mapin%mat_V2U,mapout%mat_V2U,info)
end subroutine psb_clinmap_transfer
@ -209,8 +218,8 @@ contains
call map%psb_base_linmap_type%free(info)
call map%map_X2Y%free()
call map%map_Y2X%free()
call map%mat_U2V%free()
call map%mat_V2U%free()
end subroutine c_free
@ -232,8 +241,8 @@ contains
! Base clone!
if (info == 0) call &
& map%psb_base_linmap_type%clone(mout%psb_base_linmap_type,info)
if (info == 0) call map%map_X2Y%clone(mout%map_X2Y,info)
if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info)
if (info == 0) call map%mat_U2V%clone(mout%mat_U2V,info)
if (info == 0) call map%mat_V2U%clone(mout%mat_V2U,info)
class default
info = psb_err_invalid_dynamic_type_
info = psb_err_missing_override_method_

85
base/modules/comm/psb_d_linmap_mod.f90
Unescape Escape View File

@ -44,8 +44,16 @@ module psb_d_linmap_mod
type, extends(psb_base_linmap_type) :: psb_dlinmap_type
type(psb_dspmat_type) :: map_X2Y, map_Y2X
type(psb_dspmat_type) :: mat_U2V, mat_V2U
contains
procedure, pass(map) :: map_U2V_a => psb_d_map_U2V_a
procedure, pass(map) :: map_U2V_v => psb_d_map_U2V_v
generic, public :: map_U2V => map_U2V_a, map_U2V_v
procedure, pass(map) :: map_V2U_a => psb_d_map_V2U_a
procedure, pass(map) :: map_V2U_v => psb_d_map_V2U_v
generic, public :: map_V2U => map_V2U_a, map_V2U_v
procedure, pass(map) :: sizeof => d_map_sizeof
procedure, pass(map) :: is_asb => d_is_asb
procedure, pass(map) :: free => d_free
@ -54,52 +62,52 @@ module psb_d_linmap_mod
end type psb_dlinmap_type
interface psb_map_X2Y
subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work)
interface psb_map_U2V
subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_dpk_, psb_dlinmap_type
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine psb_d_map_X2Y
subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_d_map_U2V_a
subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_d_vect_mod, only : psb_d_vect_type
import :: psb_ipk_, psb_dpk_, psb_dlinmap_type
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_d_map_X2Y_vect
end subroutine psb_d_map_U2V_v
end interface
interface psb_map_Y2X
subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work)
interface psb_map_V2U
subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_dpk_, psb_dlinmap_type
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine psb_d_map_Y2X
subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_d_map_V2U_a
subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_d_vect_mod, only : psb_d_vect_type
import :: psb_ipk_, psb_dpk_, psb_dlinmap_type
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_d_map_Y2X_vect
end subroutine psb_d_map_V2U_v
end interface
@ -116,13 +124,13 @@ module psb_d_linmap_mod
end interface
interface psb_linmap
function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr)
function psb_d_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr)
use psb_d_mat_mod, only : psb_dspmat_type
import :: psb_ipk_, psb_dlinmap_type, psb_desc_type, psb_lpk_
implicit none
type(psb_dlinmap_type) :: psb_d_linmap
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_dspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_dspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
end function psb_d_linmap
@ -142,8 +150,8 @@ contains
integer(psb_epk_) :: val
val = map%psb_base_linmap_type%sizeof()
val = val + map%map_X2Y%sizeof()
val = val + map%map_Y2X%sizeof()
val = val + map%mat_U2V%sizeof()
val = val + map%mat_V2U%sizeof()
end function d_map_sizeof
@ -154,7 +162,7 @@ contains
logical :: val
val = map%psb_base_linmap_type%is_asb() .and. &
& map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb()
& map%mat_U2V%is_asb() .and.map%mat_V2U%is_asb()
end function d_is_asb
@ -167,26 +175,27 @@ contains
class(psb_d_base_sparse_mat), intent(in), optional :: mold
class(psb_i_base_vect_type), intent(in), optional :: imold
if (map%map_X2Y%is_asb())&
& call map%map_X2Y%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%map_Y2X%is_asb())&
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
if (map%mat_U2V%is_asb())&
& call map%mat_U2V%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%mat_V2U%is_asb())&
& call map%mat_V2U%cscnv(info,type=type,mold=mold)
if (present(imold)) then
call map%desc_X%cnv(mold=imold)
call map%desc_Y%cnv(mold=imold)
call map%desc_U%cnv(mold=imold)
call map%desc_V%cnv(mold=imold)
end if
end subroutine psb_d_map_cscnv
subroutine psb_d_linmap_sub(out_map,map_kind,desc_X, desc_Y,&
& map_X2Y, map_Y2X,iaggr,naggr)
subroutine psb_d_linmap_sub(out_map,map_kind,desc_U, desc_V,&
& mat_U2V, mat_V2U,iaggr,naggr)
use psb_d_mat_mod
implicit none
type(psb_dlinmap_type), intent(out) :: out_map
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_dspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_dspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr)
out_map = psb_linmap(map_kind,desc_U,desc_V,mat_U2V,mat_V2U,iaggr,naggr)
end subroutine psb_d_linmap_sub
subroutine psb_dlinmap_transfer(mapin,mapout,info)
@ -197,8 +206,8 @@ contains
call psb_move_alloc(mapin%psb_base_linmap_type, &
& mapout%psb_base_linmap_type,info)
call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info)
call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info)
call psb_move_alloc(mapin%mat_U2V,mapout%mat_U2V,info)
call psb_move_alloc(mapin%mat_V2U,mapout%mat_V2U,info)
end subroutine psb_dlinmap_transfer
@ -209,8 +218,8 @@ contains
call map%psb_base_linmap_type%free(info)
call map%map_X2Y%free()
call map%map_Y2X%free()
call map%mat_U2V%free()
call map%mat_V2U%free()
end subroutine d_free
@ -232,8 +241,8 @@ contains
! Base clone!
if (info == 0) call &
& map%psb_base_linmap_type%clone(mout%psb_base_linmap_type,info)
if (info == 0) call map%map_X2Y%clone(mout%map_X2Y,info)
if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info)
if (info == 0) call map%mat_U2V%clone(mout%mat_U2V,info)
if (info == 0) call map%mat_V2U%clone(mout%mat_V2U,info)
class default
info = psb_err_invalid_dynamic_type_
info = psb_err_missing_override_method_

85
base/modules/comm/psb_s_linmap_mod.f90
Unescape Escape View File

@ -44,8 +44,16 @@ module psb_s_linmap_mod
type, extends(psb_base_linmap_type) :: psb_slinmap_type
type(psb_sspmat_type) :: map_X2Y, map_Y2X
type(psb_sspmat_type) :: mat_U2V, mat_V2U
contains
procedure, pass(map) :: map_U2V_a => psb_s_map_U2V_a
procedure, pass(map) :: map_U2V_v => psb_s_map_U2V_v
generic, public :: map_U2V => map_U2V_a, map_U2V_v
procedure, pass(map) :: map_V2U_a => psb_s_map_V2U_a
procedure, pass(map) :: map_V2U_v => psb_s_map_V2U_v
generic, public :: map_V2U => map_V2U_a, map_V2U_v
procedure, pass(map) :: sizeof => s_map_sizeof
procedure, pass(map) :: is_asb => s_is_asb
procedure, pass(map) :: free => s_free
@ -54,52 +62,52 @@ module psb_s_linmap_mod
end type psb_slinmap_type
interface psb_map_X2Y
subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work)
interface psb_map_U2V
subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_spk_, psb_slinmap_type
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine psb_s_map_X2Y
subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_s_map_U2V_a
subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_s_vect_mod, only : psb_s_vect_type
import :: psb_ipk_, psb_spk_, psb_slinmap_type
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_s_map_X2Y_vect
end subroutine psb_s_map_U2V_v
end interface
interface psb_map_Y2X
subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work)
interface psb_map_V2U
subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_spk_, psb_slinmap_type
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine psb_s_map_Y2X
subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_s_map_V2U_a
subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_s_vect_mod, only : psb_s_vect_type
import :: psb_ipk_, psb_spk_, psb_slinmap_type
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_s_map_Y2X_vect
end subroutine psb_s_map_V2U_v
end interface
@ -116,13 +124,13 @@ module psb_s_linmap_mod
end interface
interface psb_linmap
function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr)
function psb_s_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr)
use psb_s_mat_mod, only : psb_sspmat_type
import :: psb_ipk_, psb_slinmap_type, psb_desc_type, psb_lpk_
implicit none
type(psb_slinmap_type) :: psb_s_linmap
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_sspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_sspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
end function psb_s_linmap
@ -142,8 +150,8 @@ contains
integer(psb_epk_) :: val
val = map%psb_base_linmap_type%sizeof()
val = val + map%map_X2Y%sizeof()
val = val + map%map_Y2X%sizeof()
val = val + map%mat_U2V%sizeof()
val = val + map%mat_V2U%sizeof()
end function s_map_sizeof
@ -154,7 +162,7 @@ contains
logical :: val
val = map%psb_base_linmap_type%is_asb() .and. &
& map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb()
& map%mat_U2V%is_asb() .and.map%mat_V2U%is_asb()
end function s_is_asb
@ -167,26 +175,27 @@ contains
class(psb_s_base_sparse_mat), intent(in), optional :: mold
class(psb_i_base_vect_type), intent(in), optional :: imold
if (map%map_X2Y%is_asb())&
& call map%map_X2Y%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%map_Y2X%is_asb())&
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
if (map%mat_U2V%is_asb())&
& call map%mat_U2V%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%mat_V2U%is_asb())&
& call map%mat_V2U%cscnv(info,type=type,mold=mold)
if (present(imold)) then
call map%desc_X%cnv(mold=imold)
call map%desc_Y%cnv(mold=imold)
call map%desc_U%cnv(mold=imold)
call map%desc_V%cnv(mold=imold)
end if
end subroutine psb_s_map_cscnv
subroutine psb_s_linmap_sub(out_map,map_kind,desc_X, desc_Y,&
& map_X2Y, map_Y2X,iaggr,naggr)
subroutine psb_s_linmap_sub(out_map,map_kind,desc_U, desc_V,&
& mat_U2V, mat_V2U,iaggr,naggr)
use psb_s_mat_mod
implicit none
type(psb_slinmap_type), intent(out) :: out_map
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_sspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_sspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr)
out_map = psb_linmap(map_kind,desc_U,desc_V,mat_U2V,mat_V2U,iaggr,naggr)
end subroutine psb_s_linmap_sub
subroutine psb_slinmap_transfer(mapin,mapout,info)
@ -197,8 +206,8 @@ contains
call psb_move_alloc(mapin%psb_base_linmap_type, &
& mapout%psb_base_linmap_type,info)
call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info)
call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info)
call psb_move_alloc(mapin%mat_U2V,mapout%mat_U2V,info)
call psb_move_alloc(mapin%mat_V2U,mapout%mat_V2U,info)
end subroutine psb_slinmap_transfer
@ -209,8 +218,8 @@ contains
call map%psb_base_linmap_type%free(info)
call map%map_X2Y%free()
call map%map_Y2X%free()
call map%mat_U2V%free()
call map%mat_V2U%free()
end subroutine s_free
@ -232,8 +241,8 @@ contains
! Base clone!
if (info == 0) call &
& map%psb_base_linmap_type%clone(mout%psb_base_linmap_type,info)
if (info == 0) call map%map_X2Y%clone(mout%map_X2Y,info)
if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info)
if (info == 0) call map%mat_U2V%clone(mout%mat_U2V,info)
if (info == 0) call map%mat_V2U%clone(mout%mat_V2U,info)
class default
info = psb_err_invalid_dynamic_type_
info = psb_err_missing_override_method_

85
base/modules/comm/psb_z_linmap_mod.f90
Unescape Escape View File

@ -44,8 +44,16 @@ module psb_z_linmap_mod
type, extends(psb_base_linmap_type) :: psb_zlinmap_type
type(psb_zspmat_type) :: map_X2Y, map_Y2X
type(psb_zspmat_type) :: mat_U2V, mat_V2U
contains
procedure, pass(map) :: map_U2V_a => psb_z_map_U2V_a
procedure, pass(map) :: map_U2V_v => psb_z_map_U2V_v
generic, public :: map_U2V => map_U2V_a, map_U2V_v
procedure, pass(map) :: map_V2U_a => psb_z_map_V2U_a
procedure, pass(map) :: map_V2U_v => psb_z_map_V2U_v
generic, public :: map_V2U => map_V2U_a, map_V2U_v
procedure, pass(map) :: sizeof => z_map_sizeof
procedure, pass(map) :: is_asb => z_is_asb
procedure, pass(map) :: free => z_free
@ -54,52 +62,52 @@ module psb_z_linmap_mod
end type psb_zlinmap_type
interface psb_map_X2Y
subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work)
interface psb_map_U2V
subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_dpk_, psb_zlinmap_type
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine psb_z_map_X2Y
subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_z_map_U2V_a
subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_z_vect_mod, only : psb_z_vect_type
import :: psb_ipk_, psb_dpk_, psb_zlinmap_type
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_z_map_X2Y_vect
end subroutine psb_z_map_U2V_v
end interface
interface psb_map_Y2X
subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work)
interface psb_map_V2U
subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work)
import :: psb_ipk_, psb_dpk_, psb_zlinmap_type
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), intent(out) :: y(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine psb_z_map_Y2X
subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end subroutine psb_z_map_V2U_a
subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_z_vect_mod, only : psb_z_vect_type
import :: psb_ipk_, psb_dpk_, psb_zlinmap_type
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_z_map_Y2X_vect
end subroutine psb_z_map_V2U_v
end interface
@ -116,13 +124,13 @@ module psb_z_linmap_mod
end interface
interface psb_linmap
function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr)
function psb_z_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr)
use psb_z_mat_mod, only : psb_zspmat_type
import :: psb_ipk_, psb_zlinmap_type, psb_desc_type, psb_lpk_
implicit none
type(psb_zlinmap_type) :: psb_z_linmap
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_zspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_zspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
end function psb_z_linmap
@ -142,8 +150,8 @@ contains
integer(psb_epk_) :: val
val = map%psb_base_linmap_type%sizeof()
val = val + map%map_X2Y%sizeof()
val = val + map%map_Y2X%sizeof()
val = val + map%mat_U2V%sizeof()
val = val + map%mat_V2U%sizeof()
end function z_map_sizeof
@ -154,7 +162,7 @@ contains
logical :: val
val = map%psb_base_linmap_type%is_asb() .and. &
& map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb()
& map%mat_U2V%is_asb() .and.map%mat_V2U%is_asb()
end function z_is_asb
@ -167,26 +175,27 @@ contains
class(psb_z_base_sparse_mat), intent(in), optional :: mold
class(psb_i_base_vect_type), intent(in), optional :: imold
if (map%map_X2Y%is_asb())&
& call map%map_X2Y%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%map_Y2X%is_asb())&
& call map%map_Y2X%cscnv(info,type=type,mold=mold)
if (map%mat_U2V%is_asb())&
& call map%mat_U2V%cscnv(info,type=type,mold=mold)
if (info == psb_success_ .and.map%mat_V2U%is_asb())&
& call map%mat_V2U%cscnv(info,type=type,mold=mold)
if (present(imold)) then
call map%desc_X%cnv(mold=imold)
call map%desc_Y%cnv(mold=imold)
call map%desc_U%cnv(mold=imold)
call map%desc_V%cnv(mold=imold)
end if
end subroutine psb_z_map_cscnv
subroutine psb_z_linmap_sub(out_map,map_kind,desc_X, desc_Y,&
& map_X2Y, map_Y2X,iaggr,naggr)
subroutine psb_z_linmap_sub(out_map,map_kind,desc_U, desc_V,&
& mat_U2V, mat_V2U,iaggr,naggr)
use psb_z_mat_mod
implicit none
type(psb_zlinmap_type), intent(out) :: out_map
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_zspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_zspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr)
out_map = psb_linmap(map_kind,desc_U,desc_V,mat_U2V,mat_V2U,iaggr,naggr)
end subroutine psb_z_linmap_sub
subroutine psb_zlinmap_transfer(mapin,mapout,info)
@ -197,8 +206,8 @@ contains
call psb_move_alloc(mapin%psb_base_linmap_type, &
& mapout%psb_base_linmap_type,info)
call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info)
call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info)
call psb_move_alloc(mapin%mat_U2V,mapout%mat_U2V,info)
call psb_move_alloc(mapin%mat_V2U,mapout%mat_V2U,info)
end subroutine psb_zlinmap_transfer
@ -209,8 +218,8 @@ contains
call map%psb_base_linmap_type%free(info)
call map%map_X2Y%free()
call map%map_Y2X%free()
call map%mat_U2V%free()
call map%mat_V2U%free()
end subroutine z_free
@ -232,8 +241,8 @@ contains
! Base clone!
if (info == 0) call &
& map%psb_base_linmap_type%clone(mout%psb_base_linmap_type,info)
if (info == 0) call map%map_X2Y%clone(mout%map_X2Y,info)
if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info)
if (info == 0) call map%mat_U2V%clone(mout%mat_U2V,info)
if (info == 0) call map%mat_V2U%clone(mout%mat_V2U,info)
class default
info = psb_err_invalid_dynamic_type_
info = psb_err_missing_override_method_

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

@ -33,15 +33,15 @@
!
!
!
! Takes a vector x from space map%p_desc_X and maps it onto
! map%p_desc_Y under map%map_X2Y possibly with communication
! Takes a vector x from space map%p_desc_U and maps it onto
! map%p_desc_V under map%mat_U2V possibly with communication
! due to exch_fw_idx
!
subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_c_map_X2Y
subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_c_map_U2V_a
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), intent(out) :: y(:)
@ -52,7 +52,7 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work)
complex(psb_spk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_X2Y'
character(len=20), parameter :: name='psb_map_U2V'
info = psb_success_
if (.not.map%is_asb()) then
@ -66,16 +66,16 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
ictxt = map%p_desc_V%get_context()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,x,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -83,19 +83,19 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
ictxt = map%desc_V%get_context()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,xt,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -109,12 +109,12 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_c_map_X2Y
end subroutine psb_c_map_U2V_a
subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_c_map_X2Y_vect
subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_c_map_U2V_v
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -126,7 +126,7 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
complex(psb_spk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_X2Yv'
character(len=20), parameter :: name='psb_map_U2V_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -140,24 +140,24 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
ictxt = map%p_desc_V%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
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,pty,info)
if ((info == psb_success_) .and. map%p_desc_Y%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,x,czero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -167,32 +167,32 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
ictxt = map%desc_V%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
else
call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(xt,map%desc_U,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_V,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
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_csmm(cone,map%map_X2Y,ptx,czero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
call psb_geaxpby(cone,x,czero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,ptx,czero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -211,19 +211,19 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end select
return
end subroutine psb_c_map_X2Y_vect
end subroutine psb_c_map_U2V_v
!
! Takes a vector x from space map%p_desc_Y and maps it onto
! map%p_desc_X under map%map_Y2X possibly with communication
! Takes a vector x from space map%p_desc_V and maps it onto
! map%p_desc_U under map%mat_V2U possibly with communication
! due to exch_bk_idx
!
subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_c_map_Y2X
subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_c_map_V2U_a
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), intent(out) :: y(:)
@ -234,7 +234,7 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work)
complex(psb_spk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_Y2X'
character(len=20), parameter :: name='psb_map_V2U'
info = psb_success_
if (.not.map%is_asb()) then
@ -248,16 +248,16 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
ictxt = map%p_desc_U%get_context()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,x,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -265,19 +265,19 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
ictxt = map%desc_U%get_context()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,xt,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -290,12 +290,12 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_c_map_Y2X
end subroutine psb_c_map_V2U_a
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
subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_c_map_V2U_v
implicit none
type(psb_clinmap_type), intent(in) :: map
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -307,7 +307,7 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
complex(psb_spk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_Y2Xv'
character(len=20), parameter :: name='psb_map_V2U_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -321,24 +321,24 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
ictxt = map%p_desc_U%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_U,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_csmm(cone,map%map_Y2X,x,czero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,x,czero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -348,32 +348,32 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
ictxt = map%desc_U%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
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)
call psb_geasb(xt,map%desc_V,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_U,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
call psb_geaxpby(cone,x,czero,ptx,map%desc_Y,info)
call psb_geaxpby(cone,x,czero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
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
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,ptx,czero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -390,16 +390,16 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
return
end select
end subroutine psb_c_map_Y2X_vect
end subroutine psb_c_map_V2U_v
function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
function psb_c_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr) &
& result(this)
use psb_base_mod, psb_protect_name => psb_c_linmap
implicit none
type(psb_clinmap_type) :: this
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_cspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_cspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
!
@ -411,15 +411,15 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case (psb_map_aggr_)
! OK
if (psb_is_ok_desc(desc_X)) then
this%p_desc_X=>desc_X
if (psb_is_ok_desc(desc_U)) then
this%p_desc_U=>desc_U
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (psb_is_ok_desc(desc_Y)) then
this%p_desc_Y=>desc_Y
if (psb_is_ok_desc(desc_V)) then
this%p_desc_V=>desc_V
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
if (present(iaggr)) then
if (.not.present(naggr)) then
@ -438,15 +438,15 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case(psb_map_gen_linear_)
if (desc_X%is_ok()) then
call desc_X%clone(this%desc_X,info)
if (desc_U%is_ok()) then
call desc_U%clone(this%desc_U,info)
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (desc_Y%is_ok()) then
call desc_Y%clone(this%desc_Y,info)
if (desc_V%is_ok()) then
call desc_V%clone(this%desc_V,info)
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
! If iaggr/naggr are present, copy them anyway.
if (present(iaggr)) then
@ -469,8 +469,8 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
info = 1
end select
if (info == psb_success_) call map_X2Y%clone(this%map_X2Y,info)
if (info == psb_success_) call map_Y2X%clone(this%map_Y2X,info)
if (info == psb_success_) call mat_U2V%clone(this%mat_U2V,info)
if (info == psb_success_) call mat_V2U%clone(this%mat_V2U,info)
if (info == psb_success_) then
call this%set_kind(map_kind)
end if

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

@ -33,15 +33,15 @@
!
!
!
! Takes a vector x from space map%p_desc_X and maps it onto
! map%p_desc_Y under map%map_X2Y possibly with communication
! Takes a vector x from space map%p_desc_U and maps it onto
! map%p_desc_V under map%mat_U2V possibly with communication
! due to exch_fw_idx
!
subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_d_map_X2Y
subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_d_map_U2V_a
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(out) :: y(:)
@ -52,7 +52,7 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work)
real(psb_dpk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_X2Y'
character(len=20), parameter :: name='psb_map_U2V'
info = psb_success_
if (.not.map%is_asb()) then
@ -66,16 +66,16 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
ictxt = map%p_desc_V%get_context()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,x,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -83,19 +83,19 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
ictxt = map%desc_V%get_context()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,xt,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -109,12 +109,12 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_d_map_X2Y
end subroutine psb_d_map_U2V_a
subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_d_map_X2Y_vect
subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_d_map_U2V_v
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -126,7 +126,7 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
real(psb_dpk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_X2Yv'
character(len=20), parameter :: name='psb_map_U2V_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -140,24 +140,24 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
ictxt = map%p_desc_V%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
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,pty,info)
if ((info == psb_success_) .and. map%p_desc_Y%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,x,dzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -167,32 +167,32 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
ictxt = map%desc_V%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
else
call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(xt,map%desc_U,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_V,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
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_csmm(done,map%map_X2Y,ptx,dzero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
call psb_geaxpby(done,x,dzero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,ptx,dzero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -211,19 +211,19 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end select
return
end subroutine psb_d_map_X2Y_vect
end subroutine psb_d_map_U2V_v
!
! Takes a vector x from space map%p_desc_Y and maps it onto
! map%p_desc_X under map%map_Y2X possibly with communication
! Takes a vector x from space map%p_desc_V and maps it onto
! map%p_desc_U under map%mat_V2U possibly with communication
! due to exch_bk_idx
!
subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_d_map_Y2X
subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_d_map_V2U_a
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(out) :: y(:)
@ -234,7 +234,7 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work)
real(psb_dpk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_Y2X'
character(len=20), parameter :: name='psb_map_V2U'
info = psb_success_
if (.not.map%is_asb()) then
@ -248,16 +248,16 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
ictxt = map%p_desc_U%get_context()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,x,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -265,19 +265,19 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
ictxt = map%desc_U%get_context()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,xt,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -290,12 +290,12 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_d_map_Y2X
end subroutine psb_d_map_V2U_a
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
subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_d_map_V2U_v
implicit none
type(psb_dlinmap_type), intent(in) :: map
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -307,7 +307,7 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
real(psb_dpk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_Y2Xv'
character(len=20), parameter :: name='psb_map_V2U_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -321,24 +321,24 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
ictxt = map%p_desc_U%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_U,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_csmm(done,map%map_Y2X,x,dzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,x,dzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -348,32 +348,32 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
ictxt = map%desc_U%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
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)
call psb_geasb(xt,map%desc_V,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_U,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
call psb_geaxpby(done,x,dzero,ptx,map%desc_Y,info)
call psb_geaxpby(done,x,dzero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
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
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,ptx,dzero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -390,16 +390,16 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
return
end select
end subroutine psb_d_map_Y2X_vect
end subroutine psb_d_map_V2U_v
function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
function psb_d_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr) &
& result(this)
use psb_base_mod, psb_protect_name => psb_d_linmap
implicit none
type(psb_dlinmap_type) :: this
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_dspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_dspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
!
@ -411,15 +411,15 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case (psb_map_aggr_)
! OK
if (psb_is_ok_desc(desc_X)) then
this%p_desc_X=>desc_X
if (psb_is_ok_desc(desc_U)) then
this%p_desc_U=>desc_U
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (psb_is_ok_desc(desc_Y)) then
this%p_desc_Y=>desc_Y
if (psb_is_ok_desc(desc_V)) then
this%p_desc_V=>desc_V
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
if (present(iaggr)) then
if (.not.present(naggr)) then
@ -438,15 +438,15 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case(psb_map_gen_linear_)
if (desc_X%is_ok()) then
call desc_X%clone(this%desc_X,info)
if (desc_U%is_ok()) then
call desc_U%clone(this%desc_U,info)
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (desc_Y%is_ok()) then
call desc_Y%clone(this%desc_Y,info)
if (desc_V%is_ok()) then
call desc_V%clone(this%desc_V,info)
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
! If iaggr/naggr are present, copy them anyway.
if (present(iaggr)) then
@ -469,8 +469,8 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
info = 1
end select
if (info == psb_success_) call map_X2Y%clone(this%map_X2Y,info)
if (info == psb_success_) call map_Y2X%clone(this%map_Y2X,info)
if (info == psb_success_) call mat_U2V%clone(this%mat_U2V,info)
if (info == psb_success_) call mat_V2U%clone(this%mat_V2U,info)
if (info == psb_success_) then
call this%set_kind(map_kind)
end if

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

@ -33,15 +33,15 @@
!
!
!
! Takes a vector x from space map%p_desc_X and maps it onto
! map%p_desc_Y under map%map_X2Y possibly with communication
! Takes a vector x from space map%p_desc_U and maps it onto
! map%p_desc_V under map%mat_U2V possibly with communication
! due to exch_fw_idx
!
subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_s_map_X2Y
subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_s_map_U2V_a
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), intent(out) :: y(:)
@ -52,7 +52,7 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work)
real(psb_spk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_X2Y'
character(len=20), parameter :: name='psb_map_U2V'
info = psb_success_
if (.not.map%is_asb()) then
@ -66,16 +66,16 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
ictxt = map%p_desc_V%get_context()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,x,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -83,19 +83,19 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
ictxt = map%desc_V%get_context()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,xt,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -109,12 +109,12 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_s_map_X2Y
end subroutine psb_s_map_U2V_a
subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_s_map_X2Y_vect
subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_s_map_U2V_v
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -126,7 +126,7 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
real(psb_spk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_X2Yv'
character(len=20), parameter :: name='psb_map_U2V_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -140,24 +140,24 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
ictxt = map%p_desc_V%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
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,pty,info)
if ((info == psb_success_) .and. map%p_desc_Y%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,x,szero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -167,32 +167,32 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
ictxt = map%desc_V%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
else
call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(xt,map%desc_U,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_V,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
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_csmm(sone,map%map_X2Y,ptx,szero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
call psb_geaxpby(sone,x,szero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,ptx,szero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -211,19 +211,19 @@ subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end select
return
end subroutine psb_s_map_X2Y_vect
end subroutine psb_s_map_U2V_v
!
! Takes a vector x from space map%p_desc_Y and maps it onto
! map%p_desc_X under map%map_Y2X possibly with communication
! Takes a vector x from space map%p_desc_V and maps it onto
! map%p_desc_U under map%mat_V2U possibly with communication
! due to exch_bk_idx
!
subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_s_map_Y2X
subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_s_map_V2U_a
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), intent(out) :: y(:)
@ -234,7 +234,7 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work)
real(psb_spk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_Y2X'
character(len=20), parameter :: name='psb_map_V2U'
info = psb_success_
if (.not.map%is_asb()) then
@ -248,16 +248,16 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
ictxt = map%p_desc_U%get_context()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,x,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -265,19 +265,19 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
ictxt = map%desc_U%get_context()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,xt,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -290,12 +290,12 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_s_map_Y2X
end subroutine psb_s_map_V2U_a
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
subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_s_map_V2U_v
implicit none
type(psb_slinmap_type), intent(in) :: map
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -307,7 +307,7 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
real(psb_spk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_Y2Xv'
character(len=20), parameter :: name='psb_map_V2U_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -321,24 +321,24 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
ictxt = map%p_desc_U%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_U,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_csmm(sone,map%map_Y2X,x,szero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,x,szero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -348,32 +348,32 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
ictxt = map%desc_U%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
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)
call psb_geasb(xt,map%desc_V,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_U,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
call psb_geaxpby(sone,x,szero,ptx,map%desc_Y,info)
call psb_geaxpby(sone,x,szero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
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
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,ptx,szero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -390,16 +390,16 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
return
end select
end subroutine psb_s_map_Y2X_vect
end subroutine psb_s_map_V2U_v
function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
function psb_s_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr) &
& result(this)
use psb_base_mod, psb_protect_name => psb_s_linmap
implicit none
type(psb_slinmap_type) :: this
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_sspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_sspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
!
@ -411,15 +411,15 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case (psb_map_aggr_)
! OK
if (psb_is_ok_desc(desc_X)) then
this%p_desc_X=>desc_X
if (psb_is_ok_desc(desc_U)) then
this%p_desc_U=>desc_U
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (psb_is_ok_desc(desc_Y)) then
this%p_desc_Y=>desc_Y
if (psb_is_ok_desc(desc_V)) then
this%p_desc_V=>desc_V
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
if (present(iaggr)) then
if (.not.present(naggr)) then
@ -438,15 +438,15 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case(psb_map_gen_linear_)
if (desc_X%is_ok()) then
call desc_X%clone(this%desc_X,info)
if (desc_U%is_ok()) then
call desc_U%clone(this%desc_U,info)
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (desc_Y%is_ok()) then
call desc_Y%clone(this%desc_Y,info)
if (desc_V%is_ok()) then
call desc_V%clone(this%desc_V,info)
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
! If iaggr/naggr are present, copy them anyway.
if (present(iaggr)) then
@ -469,8 +469,8 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
info = 1
end select
if (info == psb_success_) call map_X2Y%clone(this%map_X2Y,info)
if (info == psb_success_) call map_Y2X%clone(this%map_Y2X,info)
if (info == psb_success_) call mat_U2V%clone(this%mat_U2V,info)
if (info == psb_success_) call mat_V2U%clone(this%mat_V2U,info)
if (info == psb_success_) then
call this%set_kind(map_kind)
end if

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

@ -33,15 +33,15 @@
!
!
!
! Takes a vector x from space map%p_desc_X and maps it onto
! map%p_desc_Y under map%map_X2Y possibly with communication
! Takes a vector x from space map%p_desc_U and maps it onto
! map%p_desc_V under map%mat_U2V possibly with communication
! due to exch_fw_idx
!
subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_z_map_X2Y
subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_z_map_U2V_a
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), intent(out) :: y(:)
@ -52,7 +52,7 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work)
complex(psb_dpk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_X2Y'
character(len=20), parameter :: name='psb_map_U2V'
info = psb_success_
if (.not.map%is_asb()) then
@ -66,16 +66,16 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
ictxt = map%p_desc_V%get_context()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,x,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -83,19 +83,19 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
ictxt = map%desc_V%get_context()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,xt,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ictxt,yt(1:nr2))
end if
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -109,12 +109,12 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_z_map_X2Y
end subroutine psb_z_map_U2V_a
subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_z_map_X2Y_vect
subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_z_map_U2V_v
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -126,7 +126,7 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
complex(psb_dpk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_X2Yv'
character(len=20), parameter :: name='psb_map_U2V_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -140,24 +140,24 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
ictxt = map%p_desc_V%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
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,pty,info)
if ((info == psb_success_) .and. map%p_desc_Y%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,x,zzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -167,32 +167,32 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_Y%get_context()
ictxt = map%desc_V%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_X%get_local_rows()
nc1 = map%desc_X%get_local_cols()
nr2 = map%desc_Y%get_global_rows()
nc2 = map%desc_Y%get_local_cols()
nr1 = map%desc_U%get_local_rows()
nc1 = map%desc_U%get_local_cols()
nr2 = map%desc_V%get_global_rows()
nc2 = map%desc_V%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
else
call psb_geasb(xt,map%desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_Y,info,scratch=.true.,mold=x%v)
call psb_geasb(xt,map%desc_U,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_V,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
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_csmm(zone,map%map_X2Y,ptx,zzero,pty,info)
if ((info == psb_success_) .and. map%desc_Y%is_repl().and.(np>1)) then
call psb_geaxpby(zone,x,zzero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,ptx,zzero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_Y,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -211,19 +211,19 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work,vtx,vty)
end select
return
end subroutine psb_z_map_X2Y_vect
end subroutine psb_z_map_U2V_v
!
! Takes a vector x from space map%p_desc_Y and maps it onto
! map%p_desc_X under map%map_Y2X possibly with communication
! Takes a vector x from space map%p_desc_V and maps it onto
! map%p_desc_U under map%mat_V2U possibly with communication
! due to exch_bk_idx
!
subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_z_map_Y2X
subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work)
use psb_base_mod, psb_protect_name => psb_z_map_V2U_a
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), intent(out) :: y(:)
@ -234,7 +234,7 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work)
complex(psb_dpk_), allocatable :: xt(:), yt(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt
character(len=20), parameter :: name='psb_map_Y2X'
character(len=20), parameter :: name='psb_map_V2U'
info = psb_success_
if (.not.map%is_asb()) then
@ -248,16 +248,16 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
ictxt = map%p_desc_U%get_context()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
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_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,x,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -265,19 +265,19 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
ictxt = map%desc_U%get_context()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(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_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,xt,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ictxt,yt(1:nr2))
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,yt,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -290,12 +290,12 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work)
return
end select
end subroutine psb_z_map_Y2X
end subroutine psb_z_map_V2U_a
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
subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
use psb_base_mod, psb_protect_name => psb_z_map_V2U_v
implicit none
type(psb_zlinmap_type), intent(in) :: map
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
@ -307,7 +307,7 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
complex(psb_dpk_), allocatable :: xta(:), yta(:)
integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,&
& map_kind, nr, ictxt, iam, np
character(len=20), parameter :: name='psb_map_Y2Xv'
character(len=20), parameter :: name='psb_map_V2U_v'
info = psb_success_
if (.not.map%is_asb()) then
@ -321,24 +321,24 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_X%get_context()
ictxt = map%p_desc_U%get_context()
call psb_info(ictxt,iam,np)
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
if (present(vty)) then
pty => vty
else
call psb_geasb(yt,map%p_desc_X,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%p_desc_U,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_csmm(zone,map%map_Y2X,x,zzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl().and.(np>1)) then
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,x,zzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -348,32 +348,32 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
case(psb_map_gen_linear_)
ictxt = map%desc_X%get_context()
ictxt = map%desc_U%get_context()
call psb_info(ictxt,iam,np)
nr1 = map%desc_Y%get_local_rows()
nc1 = map%desc_Y%get_local_cols()
nr2 = map%desc_X%get_global_rows()
nc2 = map%desc_X%get_local_cols()
nr1 = map%desc_V%get_local_rows()
nc1 = map%desc_V%get_local_cols()
nr2 = map%desc_U%get_global_rows()
nc2 = map%desc_U%get_local_cols()
if (present(vtx).and.present(vty)) then
ptx => vtx
pty => vty
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)
call psb_geasb(xt,map%desc_V,info,scratch=.true.,mold=x%v)
call psb_geasb(yt,map%desc_U,info,scratch=.true.,mold=x%v)
ptx => xt
pty => yt
end if
call psb_geaxpby(zone,x,zzero,ptx,map%desc_Y,info)
call psb_geaxpby(zone,x,zzero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_Y,info,work=work)
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
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,ptx,zzero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
call psb_sum(ictxt,yta(1:nr2))
call pty%set(yta)
end if
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_X,info)
if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info)
if (info /= psb_success_) then
write(psb_err_unit,*) trim(name),' Error from inner routines',info
info = -1
@ -390,16 +390,16 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work,vtx,vty)
return
end select
end subroutine psb_z_map_Y2X_vect
end subroutine psb_z_map_V2U_v
function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
function psb_z_linmap(map_kind,desc_U, desc_V, mat_U2V, mat_V2U,iaggr,naggr) &
& result(this)
use psb_base_mod, psb_protect_name => psb_z_linmap
implicit none
type(psb_zlinmap_type) :: this
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_zspmat_type), intent(inout) :: map_X2Y, map_Y2X
type(psb_desc_type), target :: desc_U, desc_V
type(psb_zspmat_type), intent(inout) :: mat_U2V, mat_V2U
integer(psb_ipk_), intent(in) :: map_kind
integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:)
!
@ -411,15 +411,15 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case (psb_map_aggr_)
! OK
if (psb_is_ok_desc(desc_X)) then
this%p_desc_X=>desc_X
if (psb_is_ok_desc(desc_U)) then
this%p_desc_U=>desc_U
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (psb_is_ok_desc(desc_Y)) then
this%p_desc_Y=>desc_Y
if (psb_is_ok_desc(desc_V)) then
this%p_desc_V=>desc_V
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
if (present(iaggr)) then
if (.not.present(naggr)) then
@ -438,15 +438,15 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
case(psb_map_gen_linear_)
if (desc_X%is_ok()) then
call desc_X%clone(this%desc_X,info)
if (desc_U%is_ok()) then
call desc_U%clone(this%desc_U,info)
else
info = psb_err_pivot_too_small_
info = psb_err_invalid_cd_state_
endif
if (desc_Y%is_ok()) then
call desc_Y%clone(this%desc_Y,info)
if (desc_V%is_ok()) then
call desc_V%clone(this%desc_V,info)
else
info = psb_err_invalid_ovr_num_
info = psb_err_invalid_cd_state_
endif
! If iaggr/naggr are present, copy them anyway.
if (present(iaggr)) then
@ -469,8 +469,8 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) &
info = 1
end select
if (info == psb_success_) call map_X2Y%clone(this%map_X2Y,info)
if (info == psb_success_) call map_Y2X%clone(this%map_Y2X,info)
if (info == psb_success_) call mat_U2V%clone(this%mat_U2V,info)
if (info == psb_success_) call mat_V2U%clone(this%mat_V2U,info)
if (info == psb_success_) then
call this%set_kind(map_kind)
end if

Write Preview
Loading…
Cancel
Save