fdurastante/amg4psblas
1
0
Fork 0
mirror of https://github.com/sfilippone/amg4psblas.git synced 2026-10-06 14:44:55 +00:00
Code Issues Packages Projects Releases Wiki Activity

Setup infrastructure for REMAP

Browse Source
This commit is contained in:
Salvatore Filippone
2020-11-07 17:17:01 +01:00
parent c394470160
commit 0ebf9f1d1c
8 changed files with 441 additions and 113 deletions
Download Patch File Download Diff File Expand all files Collapse all files
amgprec/amg_c_onelev_mod.f90
+105
View File
@@ -152,6 +152,15 @@ module amg_c_onelev_mod
end type amg_cmlprec_wrk_type
private :: c_wrk_alloc, c_wrk_free, &
& c_wrk_clone, c_wrk_move_alloc, c_wrk_cnv, c_wrk_sizeof
type amg_c_remap_data_type
type(psb_cspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: ipdest
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:)
!!$ contains
!!$ procedure, pass(rmp) :: clone => c_remap_data_clone
end type amg_c_remap_data_type
type amg_c_onelev_type
class(amg_c_base_smoother_type), allocatable :: sm, sm2a
@@ -167,6 +176,7 @@ module amg_c_onelev_mod
type(psb_desc_type), pointer :: base_desc => null()
type(psb_lcspmat_type) :: tprol
type(psb_clinmap_type) :: map
type(amg_c_remap_data_type) :: remap_data
real(psb_spk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => c_base_onelev_bld_tprol
@@ -196,6 +206,13 @@ module amg_c_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc
procedure, pass(lv) :: map_up_a => amg_c_base_onelev_map_up_a
procedure, pass(lv) :: map_dw_a => amg_c_base_onelev_map_dw_a
procedure, pass(lv) :: map_up_v => amg_c_base_onelev_map_up_v
procedure, pass(lv) :: map_dw_v => amg_c_base_onelev_map_dw_v
generic, public :: map_up => map_up_a, map_up_v
generic, public :: map_dw => map_dw_a, map_dw_v
end type amg_c_onelev_type
type amg_c_onelev_node
@@ -821,4 +838,92 @@ contains
end if
end function c_wrk_sizeof
subroutine amg_c_base_onelev_map_up_a(lv,alpha,u,beta,v,info,work)
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(inout) :: u(:)
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_c_base_onelev_map_up_a
subroutine amg_c_base_onelev_map_dw_a(lv,alpha,v,beta,u,info,work)
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(inout) :: u(:)
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_c_base_onelev_map_dw_a
subroutine amg_c_base_onelev_map_up_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_c_base_onelev_map_up_v
subroutine amg_c_base_onelev_map_dw_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
implicit none
class(amg_c_onelev_type), target, intent(inout) :: lv
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_c_base_onelev_map_dw_v
end module amg_c_onelev_mod
amgprec/amg_d_onelev_mod.f90
+70 -57
View File
@@ -157,9 +157,9 @@ module amg_d_onelev_mod
type(psb_dspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: ipdest
integer(psb_ipk_), allocatable :: isrc(:)
contains
procedure, pass(rmp) :: clone => d_remap_data_clone
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:)
!!$ contains
!!$ procedure, pass(rmp) :: clone => d_remap_data_clone
end type amg_d_remap_data_type
type amg_d_onelev_type
@@ -177,7 +177,7 @@ module amg_d_onelev_mod
type(psb_ldspmat_type) :: tprol
type(psb_dlinmap_type) :: map
type(amg_d_remap_data_type) :: remap_data
real(psb_dpk_) :: szratio
real(psb_dpk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => d_base_onelev_bld_tprol
procedure, pass(lv) :: mat_asb => amg_d_base_onelev_mat_asb
@@ -206,9 +206,13 @@ module amg_d_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc
procedure, pass(lv) :: map_u2v => amg_d_base_onelev_map_u2v
procedure, pass(lv) :: map_v2u => amg_d_base_onelev_map_v2u
procedure, pass(lv) :: map_up_a => amg_d_base_onelev_map_up_a
procedure, pass(lv) :: map_dw_a => amg_d_base_onelev_map_dw_a
procedure, pass(lv) :: map_up_v => amg_d_base_onelev_map_up_v
procedure, pass(lv) :: map_dw_v => amg_d_base_onelev_map_dw_v
generic, public :: map_up => map_up_a, map_up_v
generic, public :: map_dw => map_dw_a, map_dw_v
end type amg_d_onelev_type
type amg_d_onelev_node
@@ -224,8 +228,7 @@ module amg_d_onelev_mod
interface
subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_ldspmat_type, psb_lpk_
import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_ldspmat_type, psb_lpk_
import :: amg_d_onelev_type
implicit none
class(amg_d_onelev_type), intent(inout), target :: lv
@@ -409,32 +412,6 @@ interface
end subroutine amg_d_base_onelev_dump
end interface
!!$ interface
!!$ subroutine amg_d_base_onelev_map_u2v(lv,alpha,vect_u,beta,vect_v,info)
!!$ import :: psb_d_base_sparse_mat, psb_d_vect_type, &
!!$ & psb_i_base_vect_type, psb_dpk_, amg_d_onelev_type, &
!!$ & psb_ipk_, psb_epk_, psb_desc_type
!!$ implicit none
!!$ class(amg_d_onelev_type), target, intent(inout) :: lv
!!$ real(psb_dpk_), intent(in) :: alpha, beta
!!$ type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine amg_d_base_onelev_map_u2v
!!$ end interface
!!$
!!$ interface
!!$ subroutine amg_d_base_onelev_map_v2u(lv,alpha,vect_v,beta,vect_u,info)
!!$ import :: psb_d_base_sparse_mat, psb_d_vect_type, &
!!$ & psb_i_base_vect_type, psb_dpk_, amg_d_onelev_type, &
!!$ & psb_ipk_, psb_epk_, psb_desc_type
!!$ implicit none
!!$ class(amg_d_onelev_type), target, intent(inout) :: lv
!!$ real(psb_dpk_), intent(in) :: alpha, beta
!!$ type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine amg_d_base_onelev_map_v2u
!!$ end interface
contains
!
! Function returning the size of the amg_prec_type data structure
@@ -594,7 +571,6 @@ contains
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
if (info == psb_success_) call lv%map%clone(lvout%map,info)
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
lvout%base_a => lv%base_a
lvout%base_desc => lv%base_desc
@@ -602,17 +578,6 @@ contains
end subroutine d_base_onelev_clone
subroutine d_remap_data_clone(rmp,rmpout,info)
Implicit None
! Arguments
class(amg_d_remap_data_type), target, intent(inout) :: rmp
class(amg_d_remap_data_type), target, intent(inout) :: rmpout
integer(psb_ipk_), intent(out) :: info
end subroutine d_remap_data_clone
subroutine d_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
@@ -873,27 +838,51 @@ contains
end if
end function d_wrk_sizeof
subroutine amg_d_base_onelev_map_u2v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
subroutine amg_d_base_onelev_map_up_a(lv,alpha,u,beta,v,info,work)
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_dpk_), intent(inout) :: u(:)
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_d_base_onelev_map_u2v
end subroutine amg_d_base_onelev_map_up_a
subroutine amg_d_base_onelev_map_v2u(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
subroutine amg_d_base_onelev_map_dw_a(lv,alpha,v,beta,u,info,work)
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_dpk_), intent(inout) :: u(:)
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_d_base_onelev_map_dw_a
subroutine amg_d_base_onelev_map_up_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
@@ -906,11 +895,35 @@ contains
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_d_base_onelev_map_v2u
end subroutine amg_d_base_onelev_map_up_v
subroutine amg_d_base_onelev_map_dw_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_d_base_onelev_map_dw_v
end module amg_d_onelev_mod
amgprec/amg_s_onelev_mod.f90
+105
View File
@@ -152,6 +152,15 @@ module amg_s_onelev_mod
end type amg_smlprec_wrk_type
private :: s_wrk_alloc, s_wrk_free, &
& s_wrk_clone, s_wrk_move_alloc, s_wrk_cnv, s_wrk_sizeof
type amg_s_remap_data_type
type(psb_sspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: ipdest
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:)
!!$ contains
!!$ procedure, pass(rmp) :: clone => s_remap_data_clone
end type amg_s_remap_data_type
type amg_s_onelev_type
class(amg_s_base_smoother_type), allocatable :: sm, sm2a
@@ -167,6 +176,7 @@ module amg_s_onelev_mod
type(psb_desc_type), pointer :: base_desc => null()
type(psb_lsspmat_type) :: tprol
type(psb_slinmap_type) :: map
type(amg_s_remap_data_type) :: remap_data
real(psb_spk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => s_base_onelev_bld_tprol
@@ -196,6 +206,13 @@ module amg_s_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc
procedure, pass(lv) :: map_up_a => amg_s_base_onelev_map_up_a
procedure, pass(lv) :: map_dw_a => amg_s_base_onelev_map_dw_a
procedure, pass(lv) :: map_up_v => amg_s_base_onelev_map_up_v
procedure, pass(lv) :: map_dw_v => amg_s_base_onelev_map_dw_v
generic, public :: map_up => map_up_a, map_up_v
generic, public :: map_dw => map_dw_a, map_dw_v
end type amg_s_onelev_type
type amg_s_onelev_node
@@ -821,4 +838,92 @@ contains
end if
end function s_wrk_sizeof
subroutine amg_s_base_onelev_map_up_a(lv,alpha,u,beta,v,info,work)
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout) :: u(:)
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_s_base_onelev_map_up_a
subroutine amg_s_base_onelev_map_dw_a(lv,alpha,v,beta,u,info,work)
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout) :: u(:)
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_s_base_onelev_map_dw_a
subroutine amg_s_base_onelev_map_up_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_s_base_onelev_map_up_v
subroutine amg_s_base_onelev_map_dw_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
implicit none
class(amg_s_onelev_type), target, intent(inout) :: lv
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_s_base_onelev_map_dw_v
end module amg_s_onelev_mod
amgprec/amg_z_onelev_mod.f90
+105
View File
@@ -152,6 +152,15 @@ module amg_z_onelev_mod
end type amg_zmlprec_wrk_type
private :: z_wrk_alloc, z_wrk_free, &
& z_wrk_clone, z_wrk_move_alloc, z_wrk_cnv, z_wrk_sizeof
type amg_z_remap_data_type
type(psb_zspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: ipdest
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:)
!!$ contains
!!$ procedure, pass(rmp) :: clone => z_remap_data_clone
end type amg_z_remap_data_type
type amg_z_onelev_type
class(amg_z_base_smoother_type), allocatable :: sm, sm2a
@@ -167,6 +176,7 @@ module amg_z_onelev_mod
type(psb_desc_type), pointer :: base_desc => null()
type(psb_lzspmat_type) :: tprol
type(psb_zlinmap_type) :: map
type(amg_z_remap_data_type) :: remap_data
real(psb_dpk_) :: szratio
contains
procedure, pass(lv) :: bld_tprol => z_base_onelev_bld_tprol
@@ -196,6 +206,13 @@ module amg_z_onelev_mod
procedure, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc
procedure, pass(lv) :: map_up_a => amg_z_base_onelev_map_up_a
procedure, pass(lv) :: map_dw_a => amg_z_base_onelev_map_dw_a
procedure, pass(lv) :: map_up_v => amg_z_base_onelev_map_up_v
procedure, pass(lv) :: map_dw_v => amg_z_base_onelev_map_dw_v
generic, public :: map_up => map_up_a, map_up_v
generic, public :: map_dw => map_dw_a, map_dw_v
end type amg_z_onelev_type
type amg_z_onelev_node
@@ -821,4 +838,92 @@ contains
end if
end function z_wrk_sizeof
subroutine amg_z_base_onelev_map_up_a(lv,alpha,u,beta,v,info,work)
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_dpk_), intent(inout) :: u(:)
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,u,beta,v,info,&
& work=work)
end if
end subroutine amg_z_base_onelev_map_up_a
subroutine amg_z_base_onelev_map_dw_a(lv,alpha,v,beta,u,info,work)
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_dpk_), intent(inout) :: u(:)
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,v,beta,u,info,&
& work=work)
end if
end subroutine amg_z_base_onelev_map_dw_a
subroutine amg_z_base_onelev_map_up_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_z_base_onelev_map_up_v
subroutine amg_z_base_onelev_map_dw_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
implicit none
class(amg_z_onelev_type), target, intent(inout) :: lv
complex(psb_dpk_), intent(in) :: alpha, beta
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
if (lv%remap_data%ac_pre_remap%is_asb()) then
!
! Remap has happened, deal with it
!
write(0,*) 'Remap handling not implemented yet '
else
! Default transfer
call lv%map%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if
end subroutine amg_z_base_onelev_map_dw_v
end module amg_z_onelev_mod
amgprec/impl/amg_cmlprec_aply.f90
+14 -14
View File
@@ -520,7 +520,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(cone,vx2l,&
call p%precv(level+1)%map_up(cone,vx2l,&
& czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -540,7 +540,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(cone,&
call p%precv(level+1)%map_dw(cone,&
& p%precv(level+1)%wrk%vy2l, cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -653,7 +653,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(cone,vty,&
call p%precv(level+1)%map_up(cone,vty,&
& czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -664,7 +664,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(cone,vx2l,&
call p%precv(level+1)%map_up(cone,vx2l,&
& czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -680,7 +680,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(cone,&
call p%precv(level+1)%map_dw(cone,&
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -698,7 +698,7 @@ contains
& vy2l,cone,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map%map_U2V(cone,vty,&
& call p%precv(level+1)%map_up(cone,vty,&
& czero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(cone, &
if (info == psb_success_) call p%precv(level+1)%map_dw(cone, &
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -889,7 +889,7 @@ contains
end if
! Apply the restriction
call p%precv(level + 1)%map%map_U2V(cone,vty,&
call p%precv(level + 1)%map_up(cone,vty,&
& czero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -925,7 +925,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(cone,&
call p%precv(level+1)%map_dw(cone,&
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -1415,7 +1415,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(cone,mlwrk(level)%x2l,&
& czero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = czero
@@ -1435,7 +1435,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map%map_V2U(cone,&
call p%precv(level+1)%map_dw(cone,&
& mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%ty,&
call p%precv(level+1)%map_up(cone,mlwrk(level)%ty,&
& czero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1564,7 +1564,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(cone,mlwrk(level)%x2l,&
& czero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1593,7 +1593,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(cone,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map_dw(cone,mlwrk(level+1)%y2l,&
& cone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
amgprec/impl/amg_dmlprec_aply.f90
+14 -14
View File
@@ -520,7 +520,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(done,vx2l,&
call p%precv(level+1)%map_up(done,vx2l,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -540,7 +540,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(done,&
call p%precv(level+1)%map_dw(done,&
& p%precv(level+1)%wrk%vy2l, done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -653,7 +653,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(done,vty,&
call p%precv(level+1)%map_up(done,vty,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -664,7 +664,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(done,vx2l,&
call p%precv(level+1)%map_up(done,vx2l,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -680,7 +680,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(done,&
call p%precv(level+1)%map_dw(done,&
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -698,7 +698,7 @@ contains
& vy2l,done,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map%map_U2V(done,vty,&
& call p%precv(level+1)%map_up(done,vty,&
& dzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(done, &
if (info == psb_success_) call p%precv(level+1)%map_dw(done, &
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -889,7 +889,7 @@ contains
end if
! Apply the restriction
call p%precv(level + 1)%map%map_U2V(done,vty,&
call p%precv(level + 1)%map_up(done,vty,&
& dzero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -925,7 +925,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(done,&
call p%precv(level+1)%map_dw(done,&
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -1415,7 +1415,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(done,mlwrk(level)%x2l,&
& dzero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = dzero
@@ -1435,7 +1435,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map%map_V2U(done,&
call p%precv(level+1)%map_dw(done,&
& mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%ty,&
call p%precv(level+1)%map_up(done,mlwrk(level)%ty,&
& dzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1564,7 +1564,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(done,mlwrk(level)%x2l,&
& dzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1593,7 +1593,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(done,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map_dw(done,mlwrk(level+1)%y2l,&
& done,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
amgprec/impl/amg_smlprec_aply.f90
+14 -14
View File
@@ -520,7 +520,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(sone,vx2l,&
call p%precv(level+1)%map_up(sone,vx2l,&
& szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -540,7 +540,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(sone,&
call p%precv(level+1)%map_dw(sone,&
& p%precv(level+1)%wrk%vy2l, sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -653,7 +653,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(sone,vty,&
call p%precv(level+1)%map_up(sone,vty,&
& szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -664,7 +664,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(sone,vx2l,&
call p%precv(level+1)%map_up(sone,vx2l,&
& szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -680,7 +680,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(sone,&
call p%precv(level+1)%map_dw(sone,&
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -698,7 +698,7 @@ contains
& vy2l,sone,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map%map_U2V(sone,vty,&
& call p%precv(level+1)%map_up(sone,vty,&
& szero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(sone, &
if (info == psb_success_) call p%precv(level+1)%map_dw(sone, &
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -889,7 +889,7 @@ contains
end if
! Apply the restriction
call p%precv(level + 1)%map%map_U2V(sone,vty,&
call p%precv(level + 1)%map_up(sone,vty,&
& szero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -925,7 +925,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(sone,&
call p%precv(level+1)%map_dw(sone,&
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -1415,7 +1415,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(sone,mlwrk(level)%x2l,&
& szero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = szero
@@ -1435,7 +1435,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map%map_V2U(sone,&
call p%precv(level+1)%map_dw(sone,&
& mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%ty,&
call p%precv(level+1)%map_up(sone,mlwrk(level)%ty,&
& szero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1564,7 +1564,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(sone,mlwrk(level)%x2l,&
& szero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1593,7 +1593,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(sone,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map_dw(sone,mlwrk(level+1)%y2l,&
& sone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
amgprec/impl/amg_zmlprec_aply.f90
+14 -14
View File
@@ -520,7 +520,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(zone,vx2l,&
call p%precv(level+1)%map_up(zone,vx2l,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -540,7 +540,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(zone,&
call p%precv(level+1)%map_dw(zone,&
& p%precv(level+1)%wrk%vy2l, zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -653,7 +653,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(zone,vty,&
call p%precv(level+1)%map_up(zone,vty,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -664,7 +664,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(zone,vx2l,&
call p%precv(level+1)%map_up(zone,vx2l,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -680,7 +680,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(zone,&
call p%precv(level+1)%map_dw(zone,&
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -698,7 +698,7 @@ contains
& vy2l,zone,vty,&
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) &
& call p%precv(level+1)%map%map_U2V(zone,vty,&
& call p%precv(level+1)%map_up(zone,vty,&
& zzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then
@@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info)
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(zone, &
if (info == psb_success_) call p%precv(level+1)%map_dw(zone, &
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -889,7 +889,7 @@ contains
end if
! Apply the restriction
call p%precv(level + 1)%map%map_U2V(zone,vty,&
call p%precv(level + 1)%map_up(zone,vty,&
& zzero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@@ -925,7 +925,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(zone,&
call p%precv(level+1)%map_dw(zone,&
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@@ -1415,7 +1415,7 @@ contains
if (level < nlev) then
! Apply the restriction
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(zone,mlwrk(level)%x2l,&
& zzero,mlwrk(level+1)%x2l,&
& info,work=work)
mlwrk(level+1)%y2l(:) = zzero
@@ -1435,7 +1435,7 @@ contains
!
! Apply the prolongator and add correction.
!
call p%precv(level+1)%map%map_V2U(zone,&
call p%precv(level+1)%map_dw(zone,&
& mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,&
& info,work=work)
if (info /= psb_success_) then
@@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue')
goto 9999
end if
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%ty,&
call p%precv(level+1)%map_up(zone,mlwrk(level)%ty,&
& zzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1564,7 +1564,7 @@ contains
end if
else
! Shortcut: just transfer x2l.
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%x2l,&
call p%precv(level+1)%map_up(zone,mlwrk(level)%x2l,&
& zzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@@ -1593,7 +1593,7 @@ contains
!
! Apply the prolongator
!
call p%precv(level+1)%map%map_V2U(zone,mlwrk(level+1)%y2l,&
call p%precv(level+1)%map_dw(zone,mlwrk(level+1)%y2l,&
& zone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&