From 0ebf9f1d1c2dda4ec15ce49eab4696baf1c518d6 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 7 Nov 2020 17:17:01 +0100 Subject: [PATCH] Setup infrastructure for REMAP --- amgprec/amg_c_onelev_mod.f90 | 105 +++++++++++++++++++++++++++ amgprec/amg_d_onelev_mod.f90 | 115 +++++++++++++++++------------- amgprec/amg_s_onelev_mod.f90 | 105 +++++++++++++++++++++++++++ amgprec/amg_z_onelev_mod.f90 | 105 +++++++++++++++++++++++++++ amgprec/impl/amg_cmlprec_aply.f90 | 28 ++++---- amgprec/impl/amg_dmlprec_aply.f90 | 28 ++++---- amgprec/impl/amg_smlprec_aply.f90 | 28 ++++---- amgprec/impl/amg_zmlprec_aply.f90 | 28 ++++---- 8 files changed, 435 insertions(+), 107 deletions(-) diff --git a/amgprec/amg_c_onelev_mod.f90 b/amgprec/amg_c_onelev_mod.f90 index 77626f2c..bee7fd7b 100644 --- a/amgprec/amg_c_onelev_mod.f90 +++ b/amgprec/amg_c_onelev_mod.f90 @@ -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 diff --git a/amgprec/amg_d_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index b2865d1a..1d51169b 100644 --- a/amgprec/amg_d_onelev_mod.f90 +++ b/amgprec/amg_d_onelev_mod.f90 @@ -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,8 +838,51 @@ contains end if 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 class(amg_d_onelev_type), target, intent(inout) :: lv real(psb_dpk_), intent(in) :: alpha, beta @@ -887,13 +895,16 @@ 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_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 class(amg_d_onelev_type), target, intent(inout) :: lv real(psb_dpk_), intent(in) :: alpha, beta @@ -906,11 +917,13 @@ contains ! ! 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_v2u + end subroutine amg_d_base_onelev_map_dw_v end module amg_d_onelev_mod diff --git a/amgprec/amg_s_onelev_mod.f90 b/amgprec/amg_s_onelev_mod.f90 index d06a5fd4..0767c6ad 100644 --- a/amgprec/amg_s_onelev_mod.f90 +++ b/amgprec/amg_s_onelev_mod.f90 @@ -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 diff --git a/amgprec/amg_z_onelev_mod.f90 b/amgprec/amg_z_onelev_mod.f90 index 0a1dd867..d67ff5cd 100644 --- a/amgprec/amg_z_onelev_mod.f90 +++ b/amgprec/amg_z_onelev_mod.f90 @@ -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 diff --git a/amgprec/impl/amg_cmlprec_aply.f90 b/amgprec/impl/amg_cmlprec_aply.f90 index 8931d7db..de3c54ae 100644 --- a/amgprec/impl/amg_cmlprec_aply.f90 +++ b/amgprec/impl/amg_cmlprec_aply.f90 @@ -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,& diff --git a/amgprec/impl/amg_dmlprec_aply.f90 b/amgprec/impl/amg_dmlprec_aply.f90 index 3e7381e6..c8243229 100644 --- a/amgprec/impl/amg_dmlprec_aply.f90 +++ b/amgprec/impl/amg_dmlprec_aply.f90 @@ -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,& diff --git a/amgprec/impl/amg_smlprec_aply.f90 b/amgprec/impl/amg_smlprec_aply.f90 index 305af31e..f781ca9f 100644 --- a/amgprec/impl/amg_smlprec_aply.f90 +++ b/amgprec/impl/amg_smlprec_aply.f90 @@ -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,& diff --git a/amgprec/impl/amg_zmlprec_aply.f90 b/amgprec/impl/amg_zmlprec_aply.f90 index 1b1534f1..5ba4de1a 100644 --- a/amgprec/impl/amg_zmlprec_aply.f90 +++ b/amgprec/impl/amg_zmlprec_aply.f90 @@ -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,&