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

Setup infrastructure for REMAP

Browse Source
implement-ainv
Salvatore Filippone 4 years ago
parent c394470160
commit 0ebf9f1d1c
8 changed files with 435 additions and 107 deletions
Show Stats Download Patch File Download Diff File

105
amgprec/amg_c_onelev_mod.f90
Unescape Escape View File

@ -152,6 +152,15 @@ module amg_c_onelev_mod
end type amg_cmlprec_wrk_type end type amg_cmlprec_wrk_type
private :: c_wrk_alloc, c_wrk_free, & private :: c_wrk_alloc, c_wrk_free, &
& c_wrk_clone, c_wrk_move_alloc, c_wrk_cnv, c_wrk_sizeof & 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 type amg_c_onelev_type
class(amg_c_base_smoother_type), allocatable :: sm, sm2a 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_desc_type), pointer :: base_desc => null()
type(psb_lcspmat_type) :: tprol type(psb_lcspmat_type) :: tprol
type(psb_clinmap_type) :: map type(psb_clinmap_type) :: map
type(amg_c_remap_data_type) :: remap_data
real(psb_spk_) :: szratio real(psb_spk_) :: szratio
contains contains
procedure, pass(lv) :: bld_tprol => c_base_onelev_bld_tprol 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, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc 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 end type amg_c_onelev_type
type amg_c_onelev_node type amg_c_onelev_node
@ -821,4 +838,92 @@ contains
end if end if
end function c_wrk_sizeof 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 end module amg_c_onelev_mod

115
amgprec/amg_d_onelev_mod.f90
Unescape Escape View File

@ -157,9 +157,9 @@ module amg_d_onelev_mod
type(psb_dspmat_type) :: ac_pre_remap type(psb_dspmat_type) :: ac_pre_remap
type(psb_desc_type) :: desc_ac_pre_remap type(psb_desc_type) :: desc_ac_pre_remap
integer(psb_ipk_) :: ipdest integer(psb_ipk_) :: ipdest
integer(psb_ipk_), allocatable :: isrc(:) integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:)
contains !!$ contains
procedure, pass(rmp) :: clone => d_remap_data_clone !!$ procedure, pass(rmp) :: clone => d_remap_data_clone
end type amg_d_remap_data_type end type amg_d_remap_data_type
type amg_d_onelev_type type amg_d_onelev_type
@ -177,7 +177,7 @@ module amg_d_onelev_mod
type(psb_ldspmat_type) :: tprol type(psb_ldspmat_type) :: tprol
type(psb_dlinmap_type) :: map type(psb_dlinmap_type) :: map
type(amg_d_remap_data_type) :: remap_data type(amg_d_remap_data_type) :: remap_data
real(psb_dpk_) :: szratio real(psb_dpk_) :: szratio
contains contains
procedure, pass(lv) :: bld_tprol => d_base_onelev_bld_tprol procedure, pass(lv) :: bld_tprol => d_base_onelev_bld_tprol
procedure, pass(lv) :: mat_asb => amg_d_base_onelev_mat_asb 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, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc 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 end type amg_d_onelev_type
type amg_d_onelev_node type amg_d_onelev_node
@ -224,8 +228,7 @@ module amg_d_onelev_mod
interface interface
subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) 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_, & import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_ldspmat_type, psb_lpk_
& psb_ldspmat_type, psb_lpk_
import :: amg_d_onelev_type import :: amg_d_onelev_type
implicit none implicit none
class(amg_d_onelev_type), intent(inout), target :: lv class(amg_d_onelev_type), intent(inout), target :: lv
@ -409,32 +412,6 @@ interface
end subroutine amg_d_base_onelev_dump end subroutine amg_d_base_onelev_dump
end interface 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 contains
! !
! Function returning the size of the amg_prec_type data structure ! 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%tprol%clone(lvout%tprol,info)
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,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%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_a => lv%base_a
lvout%base_desc => lv%base_desc lvout%base_desc => lv%base_desc
@ -602,17 +578,6 @@ contains
end subroutine d_base_onelev_clone 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) subroutine d_base_onelev_move_alloc(lv, b,info)
use psb_base_mod use psb_base_mod
implicit none implicit none
@ -873,8 +838,51 @@ contains
end if end if
end function d_wrk_sizeof end function d_wrk_sizeof
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
real(psb_dpk_), intent(inout) :: u(:)
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
subroutine amg_d_base_onelev_map_u2v(lv,alpha,vect_u,beta,vect_v,info,work,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,u,beta,v,info,&
& work=work)
end if
end subroutine amg_d_base_onelev_map_up_a
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 implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta real(psb_dpk_), intent(in) :: alpha, beta
@ -887,13 +895,16 @@ contains
! !
! Remap has happened, deal with it ! Remap has happened, deal with it
! !
write(0,*) 'Remap handling not implemented yet '
else else
! Default transfer ! Default transfer
call lv%map%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty)
end if end if
end subroutine amg_d_base_onelev_map_u2v end subroutine amg_d_base_onelev_map_up_v
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_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
implicit none implicit none
class(amg_d_onelev_type), target, intent(inout) :: lv class(amg_d_onelev_type), target, intent(inout) :: lv
real(psb_dpk_), intent(in) :: alpha, beta real(psb_dpk_), intent(in) :: alpha, beta
@ -906,11 +917,13 @@ contains
! !
! Remap has happened, deal with it ! Remap has happened, deal with it
! !
write(0,*) 'Remap handling not implemented yet '
else else
! Default transfer ! Default transfer
call lv%map%map_V2U(alpha,vect_v,beta,vect_u,info,&
& work=work,vtx=vtx,vty=vty)
end if end if
end subroutine amg_d_base_onelev_map_v2u end subroutine amg_d_base_onelev_map_dw_v
end module amg_d_onelev_mod end module amg_d_onelev_mod

105
amgprec/amg_s_onelev_mod.f90
Unescape Escape View File

@ -152,6 +152,15 @@ module amg_s_onelev_mod
end type amg_smlprec_wrk_type end type amg_smlprec_wrk_type
private :: s_wrk_alloc, s_wrk_free, & private :: s_wrk_alloc, s_wrk_free, &
& s_wrk_clone, s_wrk_move_alloc, s_wrk_cnv, s_wrk_sizeof & 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 type amg_s_onelev_type
class(amg_s_base_smoother_type), allocatable :: sm, sm2a 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_desc_type), pointer :: base_desc => null()
type(psb_lsspmat_type) :: tprol type(psb_lsspmat_type) :: tprol
type(psb_slinmap_type) :: map type(psb_slinmap_type) :: map
type(amg_s_remap_data_type) :: remap_data
real(psb_spk_) :: szratio real(psb_spk_) :: szratio
contains contains
procedure, pass(lv) :: bld_tprol => s_base_onelev_bld_tprol 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, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc 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 end type amg_s_onelev_type
type amg_s_onelev_node type amg_s_onelev_node
@ -821,4 +838,92 @@ contains
end if end if
end function s_wrk_sizeof 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 end module amg_s_onelev_mod

105
amgprec/amg_z_onelev_mod.f90
Unescape Escape View File

@ -152,6 +152,15 @@ module amg_z_onelev_mod
end type amg_zmlprec_wrk_type end type amg_zmlprec_wrk_type
private :: z_wrk_alloc, z_wrk_free, & private :: z_wrk_alloc, z_wrk_free, &
& z_wrk_clone, z_wrk_move_alloc, z_wrk_cnv, z_wrk_sizeof & 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 type amg_z_onelev_type
class(amg_z_base_smoother_type), allocatable :: sm, sm2a 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_desc_type), pointer :: base_desc => null()
type(psb_lzspmat_type) :: tprol type(psb_lzspmat_type) :: tprol
type(psb_zlinmap_type) :: map type(psb_zlinmap_type) :: map
type(amg_z_remap_data_type) :: remap_data
real(psb_dpk_) :: szratio real(psb_dpk_) :: szratio
contains contains
procedure, pass(lv) :: bld_tprol => z_base_onelev_bld_tprol 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, nopass :: stringval => amg_stringval
procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc 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 end type amg_z_onelev_type
type amg_z_onelev_node type amg_z_onelev_node
@ -821,4 +838,92 @@ contains
end if end if
end function z_wrk_sizeof 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 end module amg_z_onelev_mod

28
amgprec/impl/amg_cmlprec_aply.f90
Unescape Escape View File

@ -520,7 +520,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -540,7 +540,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l, cone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -653,7 +653,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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,& & czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -664,7 +664,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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,& & czero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -680,7 +680,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -698,7 +698,7 @@ contains
& vy2l,cone,vty,& & vy2l,cone,vty,&
& base_desc,info,work=work,trans=trans) & base_desc,info,work=work,trans=trans)
if (info == psb_success_) & 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,& & czero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then if (info /= psb_success_) then
@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info) 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,& & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -889,7 +889,7 @@ contains
end if end if
! Apply the restriction ! 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,& & czero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,& &info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -925,7 +925,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,cone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -1415,7 +1415,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & czero,mlwrk(level+1)%x2l,&
& info,work=work) & info,work=work)
mlwrk(level+1)%y2l(:) = czero mlwrk(level+1)%y2l(:) = czero
@ -1435,7 +1435,7 @@ contains
! !
! Apply the prolongator and add correction. ! 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,& & mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,&
& info,work=work) & info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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) & czero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1564,7 +1564,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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) & czero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1593,7 +1593,7 @@ contains
! !
! Apply the prolongator ! 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) & cone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&

28
amgprec/impl/amg_dmlprec_aply.f90
Unescape Escape View File

@ -520,7 +520,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -540,7 +540,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l, done,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -653,7 +653,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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,& & dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -664,7 +664,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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,& & dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -680,7 +680,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -698,7 +698,7 @@ contains
& vy2l,done,vty,& & vy2l,done,vty,&
& base_desc,info,work=work,trans=trans) & base_desc,info,work=work,trans=trans)
if (info == psb_success_) & 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,& & dzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then if (info /= psb_success_) then
@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info) 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,& & p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -889,7 +889,7 @@ contains
end if end if
! Apply the restriction ! 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,& & dzero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,& &info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -925,7 +925,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,done,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -1415,7 +1415,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & dzero,mlwrk(level+1)%x2l,&
& info,work=work) & info,work=work)
mlwrk(level+1)%y2l(:) = dzero mlwrk(level+1)%y2l(:) = dzero
@ -1435,7 +1435,7 @@ contains
! !
! Apply the prolongator and add correction. ! 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,& & mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,&
& info,work=work) & info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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) & dzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1564,7 +1564,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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) & dzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1593,7 +1593,7 @@ contains
! !
! Apply the prolongator ! 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) & done,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&

28
amgprec/impl/amg_smlprec_aply.f90
Unescape Escape View File

@ -520,7 +520,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -540,7 +540,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l, sone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -653,7 +653,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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,& & szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -664,7 +664,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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,& & szero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -680,7 +680,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -698,7 +698,7 @@ contains
& vy2l,sone,vty,& & vy2l,sone,vty,&
& base_desc,info,work=work,trans=trans) & base_desc,info,work=work,trans=trans)
if (info == psb_success_) & 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,& & szero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then if (info /= psb_success_) then
@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info) 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,& & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -889,7 +889,7 @@ contains
end if end if
! Apply the restriction ! 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,& & szero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,& &info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -925,7 +925,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,sone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -1415,7 +1415,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & szero,mlwrk(level+1)%x2l,&
& info,work=work) & info,work=work)
mlwrk(level+1)%y2l(:) = szero mlwrk(level+1)%y2l(:) = szero
@ -1435,7 +1435,7 @@ contains
! !
! Apply the prolongator and add correction. ! 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,& & mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,&
& info,work=work) & info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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) & szero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1564,7 +1564,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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) & szero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1593,7 +1593,7 @@ contains
! !
! Apply the prolongator ! 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) & sone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&

28
amgprec/impl/amg_zmlprec_aply.f90
Unescape Escape View File

@ -520,7 +520,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -540,7 +540,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l, zone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -653,7 +653,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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,& & zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -664,7 +664,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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,& & zzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,& & info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -680,7 +680,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -698,7 +698,7 @@ contains
& vy2l,zone,vty,& & vy2l,zone,vty,&
& base_desc,info,work=work,trans=trans) & base_desc,info,work=work,trans=trans)
if (info == psb_success_) & 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,& & zzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
if (info /= psb_success_) then if (info /= psb_success_) then
@ -709,7 +709,7 @@ contains
call inner_ml_aply(level+1,p,trans,work,info) 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,& & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -889,7 +889,7 @@ contains
end if end if
! Apply the restriction ! 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,& & zzero,p%precv(level + 1)%wrk%vx2l,&
&info,work=work,& &info,work=work,&
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1)) & vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
@ -925,7 +925,7 @@ contains
! !
! Apply the prolongator ! 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,& & p%precv(level+1)%wrk%vy2l,zone,vy2l,&
& info,work=work,& & info,work=work,&
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1)) & vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
@ -1415,7 +1415,7 @@ contains
if (level < nlev) then if (level < nlev) then
! Apply the restriction ! 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,& & zzero,mlwrk(level+1)%x2l,&
& info,work=work) & info,work=work)
mlwrk(level+1)%y2l(:) = zzero mlwrk(level+1)%y2l(:) = zzero
@ -1435,7 +1435,7 @@ contains
! !
! Apply the prolongator and add correction. ! 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,& & mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,&
& info,work=work) & info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -1555,7 +1555,7 @@ contains
& a_err='Error during residue') & a_err='Error during residue')
goto 9999 goto 9999
end if 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) & zzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1564,7 +1564,7 @@ contains
end if end if
else else
! Shortcut: just transfer x2l. ! 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) & zzero,mlwrk(level+1)%x2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
@ -1593,7 +1593,7 @@ contains
! !
! Apply the prolongator ! 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) & zone,mlwrk(level)%y2l,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&

Write Preview
Loading…
Cancel
Save