merged with parmatch from amg-ext
Cirdans-Home
4 years ago
parent
a42413223e
commit
e9ba51c7b3
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,713 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from amg4psblas-extension
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! The aggregator object hosts the aggregation method for building
|
||||
! the multilevel hierarchy. This variant is based on the hybrid method
|
||||
! presented in
|
||||
!
|
||||
!
|
||||
! sm - class(amg_T_base_smoother_type), allocatable
|
||||
! The current level preconditioner (aka smoother).
|
||||
! parms - type(amg_RTml_parms)
|
||||
! The parameters defining the multilevel strategy.
|
||||
! ac - The local part of the current-level matrix, built by
|
||||
! coarsening the previous-level matrix.
|
||||
! desc_ac - type(psb_desc_type).
|
||||
! The communication descriptor associated to the matrix
|
||||
! stored in ac.
|
||||
! base_a - type(psb_Tspmat_type), pointer.
|
||||
! Pointer (really a pointer!) to the local part of the current
|
||||
! matrix (so we have a unified treatment of residuals).
|
||||
! We need this to avoid passing explicitly the current matrix
|
||||
! to the routine which applies the preconditioner.
|
||||
! base_desc - type(psb_desc_type), pointer.
|
||||
! Pointer to the communication descriptor associated to the
|
||||
! matrix pointed by base_a.
|
||||
! map - Stores the maps (restriction and prolongation) between the
|
||||
! vector spaces associated to the index spaces of the previous
|
||||
! and current levels.
|
||||
!
|
||||
! Methods:
|
||||
! Most methods follow the encapsulation hierarchy: they take whatever action
|
||||
! is appropriate for the current object, then call the corresponding method for
|
||||
! the contained object.
|
||||
! As an example: the descr() method prints out a description of the
|
||||
! level. It starts by invoking the descr() method of the parms object,
|
||||
! then calls the descr() method of the smoother object.
|
||||
!
|
||||
! descr - Prints a description of the object.
|
||||
! default - Set default values
|
||||
! dump - Dump to file object contents
|
||||
! set - Sets various parameters; when a request is unknown
|
||||
! it is passed to the smoother object for further processing.
|
||||
! check - Sanity checks.
|
||||
! sizeof - Total memory occupation in bytes
|
||||
! get_nzeros - Number of nonzeros
|
||||
!
|
||||
!
|
||||
|
||||
module amg_d_parmatch_aggregator_mod
|
||||
use amg_d_base_aggregator_mod
|
||||
use dmatchboxp_mod
|
||||
|
||||
type, extends(amg_d_base_aggregator_type) :: amg_d_parmatch_aggregator_type
|
||||
integer(psb_ipk_) :: matching_alg
|
||||
integer(psb_ipk_) :: n_sweeps ! When n_sweeps >1 we need an auxiliary descriptor
|
||||
integer(psb_ipk_) :: orig_aggr_size
|
||||
integer(psb_ipk_) :: jacobi_sweeps
|
||||
real(psb_dpk_), allocatable :: w(:), w_nxt(:)
|
||||
type(psb_dspmat_type), allocatable :: prol, restr
|
||||
type(psb_dspmat_type), allocatable :: ac, base_a, rwa
|
||||
type(psb_desc_type), allocatable :: desc_ac, desc_ax, base_desc, rwdesc
|
||||
integer(psb_ipk_) :: max_csize
|
||||
integer(psb_ipk_) :: max_nlevels
|
||||
logical :: reproducible_matching = .false.
|
||||
logical :: need_symmetrize = .false.
|
||||
logical :: unsmoothed_hierarchy = .true.
|
||||
contains
|
||||
procedure, pass(ag) :: bld_tprol => amg_d_parmatch_aggregator_build_tprol
|
||||
procedure, pass(ag) :: mat_bld => amg_d_parmatch_aggregator_mat_bld
|
||||
procedure, pass(ag) :: mat_asb => amg_d_parmatch_aggregator_mat_asb
|
||||
procedure, pass(ag) :: inner_mat_asb => amg_d_parmatch_aggregator_inner_mat_asb
|
||||
procedure, pass(ag) :: bld_map => amg_d_parmatch_aggregator_bld_map
|
||||
procedure, pass(ag) :: csetc => d_parmatch_aggr_csetc
|
||||
procedure, pass(ag) :: cseti => d_parmatch_aggr_cseti
|
||||
procedure, pass(ag) :: default => d_parmatch_aggr_set_default
|
||||
procedure, pass(ag) :: sizeof => d_parmatch_aggregator_sizeof
|
||||
procedure, pass(ag) :: update_next => d_parmatch_aggregator_update_next
|
||||
procedure, pass(ag) :: bld_wnxt => d_parmatch_bld_wnxt
|
||||
procedure, pass(ag) :: bld_default_w => d_bld_default_w
|
||||
procedure, pass(ag) :: set_c_default_w => d_set_prm_c_default_w
|
||||
procedure, pass(ag) :: descr => d_parmatch_aggregator_descr
|
||||
procedure, pass(ag) :: clone => d_parmatch_aggregator_clone
|
||||
procedure, pass(ag) :: free => d_parmatch_aggregator_free
|
||||
procedure, nopass :: fmt => d_parmatch_aggregator_fmt
|
||||
procedure, nopass :: xt_desc => amg_d_parmatch_aggregator_xt_desc
|
||||
end type amg_d_parmatch_aggregator_type
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine glob_transpose(ain,desc_r,desc_c,atrans,desc_rx,info)
|
||||
!!$ import :: psb_desc_type, psb_ld_coo_sparse_mat, psb_ipk_
|
||||
!!$ implicit none
|
||||
!!$ type(psb_ld_coo_sparse_mat), intent(in) :: ain
|
||||
!!$ type(psb_ld_coo_sparse_mat), intent(out) :: atrans
|
||||
!!$ type(psb_desc_type), intent(inout) :: desc_r, desc_c
|
||||
!!$ type(psb_desc_type), intent(out) :: desc_rx
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ end subroutine glob_transpose
|
||||
!!$ end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
& a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(amg_daggr_data), intent(in) :: ag_data
|
||||
type(psb_dspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
|
||||
type(psb_ldspmat_type), intent(out) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_aggregator_build_tprol
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_aggregator_mat_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_aggregator_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_aggregator_mat_asb
|
||||
end interface
|
||||
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_aggregator_inner_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
type(psb_dspmat_type), intent(inout) :: op_prol,op_restr
|
||||
type(psb_dspmat_type), intent(inout) :: ac
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_aggregator_inner_mat_asb
|
||||
end interface
|
||||
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(inout) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_spmm_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_unsmth_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_smth_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
|
||||
implicit none
|
||||
type(psb_dspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_spmm_bld_ov
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_parmatch_spmm_bld_inner(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
|
||||
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data,&
|
||||
& psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat
|
||||
implicit none
|
||||
type(psb_d_csr_sparse_mat), intent(inout) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_parmatch_spmm_bld_inner
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ Subroutine amg_d_p_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
|
||||
!!$ import
|
||||
!!$ Implicit None
|
||||
!!$ type(psb_ld_csr_sparse_mat),intent(in) :: acsr
|
||||
!!$ type(psb_ld_csr_sparse_mat),intent(inout) :: bcsr
|
||||
!!$ type(psb_ld_csr_sparse_mat),intent(out) :: ccsr
|
||||
!!$ type(psb_desc_type),intent(in) :: desc_a
|
||||
!!$ type(psb_desc_type),intent(inout) :: desc_c
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_), intent(in), optional :: data
|
||||
!!$ end Subroutine amg_d_p_csr_spspmm
|
||||
!!$ end interface
|
||||
|
||||
private :: is_legal_malg, is_legal_csize, is_legal_nsweeps, is_legal_nlevels
|
||||
|
||||
contains
|
||||
|
||||
subroutine d_bld_default_w(ag,nr)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
integer(psb_ipk_), intent(in) :: nr
|
||||
integer(psb_ipk_) :: info
|
||||
call psb_realloc(nr,ag%w,info)
|
||||
if (info /= psb_success_) return
|
||||
ag%w = done
|
||||
!call ag%set_c_default_w()
|
||||
end subroutine d_bld_default_w
|
||||
|
||||
subroutine d_set_prm_c_default_w(ag)
|
||||
use psb_realloc_mod
|
||||
use iso_c_binding
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
!write(0,*) 'prm_c_deafult_w '
|
||||
call psb_safe_ab_cpy(ag%w,ag%w_nxt,info)
|
||||
|
||||
end subroutine d_set_prm_c_default_w
|
||||
|
||||
subroutine d_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
integer(psb_lpk_), intent(in) :: ilaggr(:)
|
||||
real(psb_dpk_), intent(in) :: valaggr(:)
|
||||
integer(psb_ipk_), intent(in) :: nx
|
||||
|
||||
integer(psb_ipk_) :: info,i,j
|
||||
|
||||
! The vector was already fixed in the call to BCMatch.
|
||||
!write(0,*) 'Executing bld_wnxt ',nx
|
||||
call psb_realloc(nx,ag%w_nxt,info)
|
||||
|
||||
end subroutine d_parmatch_bld_wnxt
|
||||
|
||||
function d_parmatch_aggregator_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Parallel Matching aggregation"
|
||||
end function d_parmatch_aggregator_fmt
|
||||
|
||||
function amg_d_parmatch_aggregator_xt_desc() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function amg_d_parmatch_aggregator_xt_desc
|
||||
|
||||
function d_parmatch_aggregator_sizeof(ag) result(val)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), intent(in) :: ag
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = 4
|
||||
val = val + psb_size(ag%w) + psb_size(ag%w_nxt)
|
||||
if (allocated(ag%ac)) val = val + ag%ac%sizeof()
|
||||
if (allocated(ag%base_a)) val = val + ag%base_a%sizeof()
|
||||
if (allocated(ag%prol)) val = val + ag%prol%sizeof()
|
||||
if (allocated(ag%restr)) val = val + ag%restr%sizeof()
|
||||
if (allocated(ag%desc_ac)) val = val + ag%desc_ac%sizeof()
|
||||
if (allocated(ag%base_desc)) val = val + ag%base_desc%sizeof()
|
||||
if (allocated(ag%desc_ax)) val = val + ag%desc_ax%sizeof()
|
||||
|
||||
end function d_parmatch_aggregator_sizeof
|
||||
|
||||
subroutine d_parmatch_aggregator_descr(ag,parms,iout,info)
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), intent(in) :: ag
|
||||
type(amg_dml_parms), intent(in) :: parms
|
||||
integer(psb_ipk_), intent(in) :: iout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
write(iout,*) 'Parallel Matching Aggregator'
|
||||
write(iout,*) ' Number of matching sweeps: ',ag%n_sweeps
|
||||
write(iout,*) ' Matching algorithm : MatchBoxP (PREIS)'
|
||||
write(iout,*) 'Aggregator object type: ',ag%fmt()
|
||||
call parms%mldescr(iout,info)
|
||||
|
||||
return
|
||||
end subroutine d_parmatch_aggregator_descr
|
||||
|
||||
function is_legal_malg(alg) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: alg
|
||||
|
||||
val = (0==alg)
|
||||
end function is_legal_malg
|
||||
|
||||
function is_legal_csize(csize) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: csize
|
||||
|
||||
val = ((-1==csize).or.(csize >0))
|
||||
end function is_legal_csize
|
||||
|
||||
function is_legal_nsweeps(nsw) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: nsw
|
||||
|
||||
val = (1<=nsw)
|
||||
end function is_legal_nsweeps
|
||||
|
||||
function is_legal_nlevels(nlv) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: nlv
|
||||
|
||||
val = (1<=nlv)
|
||||
end function is_legal_nlevels
|
||||
|
||||
|
||||
subroutine d_parmatch_aggregator_update_next(ag,agnext,info)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
class(amg_d_base_aggregator_type), target, intent(inout) :: agnext
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
!
|
||||
!
|
||||
select type(agnext)
|
||||
class is (amg_d_parmatch_aggregator_type)
|
||||
if (.not.is_legal_malg(agnext%matching_alg)) &
|
||||
& agnext%matching_alg = ag%matching_alg
|
||||
if (.not.is_legal_nsweeps(agnext%n_sweeps))&
|
||||
& agnext%n_sweeps = ag%n_sweeps
|
||||
if (.not.is_legal_csize(agnext%max_csize))&
|
||||
& agnext%max_csize = ag%max_csize
|
||||
if (.not.is_legal_nlevels(agnext%max_nlevels))&
|
||||
& agnext%max_nlevels = ag%max_nlevels
|
||||
! Is this going to generate shallow copies/memory leaks/double frees?
|
||||
! To be investigated further.
|
||||
call psb_safe_ab_cpy(ag%w_nxt,agnext%w,info)
|
||||
call agnext%set_c_default_w()
|
||||
if (ag%unsmoothed_hierarchy) then
|
||||
agnext%unsmoothed_hierarchy = .true.
|
||||
call move_alloc(ag%rwdesc,agnext%base_desc)
|
||||
call move_alloc(ag%rwa,agnext%base_a)
|
||||
end if
|
||||
|
||||
class default
|
||||
! What should we do here?
|
||||
end select
|
||||
info = 0
|
||||
end subroutine d_parmatch_aggregator_update_next
|
||||
|
||||
subroutine d_parmatch_aggr_csetc(ag,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, iwhat
|
||||
character(len=20) :: name='d_parmatch_aggr_cseti'
|
||||
info = psb_success_
|
||||
|
||||
! For now we ignore IDX
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('PRMC_REPRODUCIBLE_MATCHING')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('F','FALSE')
|
||||
ag%reproducible_matching = .false.
|
||||
case('REPRODUCIBLE','TRUE','T')
|
||||
ag%reproducible_matching =.true.
|
||||
end select
|
||||
case('PRMC_NEED_SYMMETRIZE')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('FALSE','F')
|
||||
ag%need_symmetrize = .false.
|
||||
case('SYMMETRIZE','TRUE','T')
|
||||
ag%need_symmetrize =.true.
|
||||
end select
|
||||
case('PRMC_UNSMOOTHED_HIERARCHY')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('F','FALSE')
|
||||
ag%unsmoothed_hierarchy = .false.
|
||||
case('T','TRUE')
|
||||
ag%unsmoothed_hierarchy =.true.
|
||||
end select
|
||||
case default
|
||||
! Do nothing
|
||||
end select
|
||||
return
|
||||
end subroutine d_parmatch_aggr_csetc
|
||||
|
||||
subroutine d_parmatch_aggr_cseti(ag,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, iwhat
|
||||
character(len=20) :: name='d_parmatch_aggr_cseti'
|
||||
info = psb_success_
|
||||
|
||||
! For now we ignore IDX
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('PRMC_MATCH_ALG')
|
||||
ag%matching_alg=val
|
||||
case('PRMC_SWEEPS')
|
||||
ag%n_sweeps=val
|
||||
case('AGGR_SIZE')
|
||||
ag%orig_aggr_size = val
|
||||
ag%n_sweeps=max(1,ceiling(log(val*1.0)/log(2.0)))
|
||||
case('PRMC_MAX_CSIZE')
|
||||
ag%max_csize=val
|
||||
case('PRMC_MAX_NLEVELS')
|
||||
ag%max_nlevels=val
|
||||
case('PRMC_W_SIZE')
|
||||
call ag%bld_default_w(val)
|
||||
case('PRMC_REPRODUCIBLE_MATCHING')
|
||||
ag%reproducible_matching = (val == 1)
|
||||
case('PRMC_NEED_SYMMETRIZE')
|
||||
ag%need_symmetrize = (val == 1)
|
||||
case('PRMC_UNSMOOTHED_HIERARCHY')
|
||||
ag%unsmoothed_hierarchy = (val == 1)
|
||||
case default
|
||||
! Do nothing
|
||||
end select
|
||||
return
|
||||
end subroutine d_parmatch_aggr_cseti
|
||||
|
||||
subroutine d_parmatch_aggr_set_default(ag)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
|
||||
character(len=20) :: name='d_parmatch_aggr_set_default'
|
||||
ag%matching_alg = 0
|
||||
ag%n_sweeps = 1
|
||||
ag%jacobi_sweeps = 0
|
||||
ag%max_nlevels = 36
|
||||
ag%max_csize = -1
|
||||
!
|
||||
! Apparently BootCMatch works better
|
||||
! by keeping all entries
|
||||
!
|
||||
ag%do_clean_zeros = .false.
|
||||
|
||||
return
|
||||
|
||||
end subroutine d_parmatch_aggr_set_default
|
||||
|
||||
subroutine d_parmatch_aggregator_free(ag,info)
|
||||
use iso_c_binding
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if ((info == 0).and.allocated(ag%w)) deallocate(ag%w,stat=info)
|
||||
if ((info == 0).and.allocated(ag%w_nxt)) deallocate(ag%w_nxt,stat=info)
|
||||
if ((info == 0).and.allocated(ag%prol)) then
|
||||
call ag%prol%free(); deallocate(ag%prol,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%restr)) then
|
||||
call ag%restr%free(); deallocate(ag%restr,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%ac)) then
|
||||
call ag%ac%free(); deallocate(ag%ac,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%base_a)) then
|
||||
call ag%base_a%free(); deallocate(ag%base_a,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%rwa)) then
|
||||
call ag%rwa%free(); deallocate(ag%rwa,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%desc_ac)) then
|
||||
call ag%desc_ac%free(info); deallocate(ag%desc_ac,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%desc_ax)) then
|
||||
call ag%desc_ax%free(info); deallocate(ag%desc_ax,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%base_desc)) then
|
||||
call ag%base_desc%free(info); deallocate(ag%base_desc,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%rwdesc)) then
|
||||
call ag%rwdesc%free(info); deallocate(ag%rwdesc,stat=info)
|
||||
end if
|
||||
|
||||
end subroutine d_parmatch_aggregator_free
|
||||
|
||||
subroutine d_parmatch_aggregator_clone(ag,agnext,info)
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
|
||||
class(amg_d_base_aggregator_type), allocatable, intent(inout) :: agnext
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(agnext)) then
|
||||
call agnext%free(info)
|
||||
if (info == 0) deallocate(agnext,stat=info)
|
||||
end if
|
||||
if (info /= 0) return
|
||||
allocate(agnext,source=ag,stat=info)
|
||||
select type(agnext)
|
||||
class is (amg_d_parmatch_aggregator_type)
|
||||
call agnext%set_c_default_w()
|
||||
class default
|
||||
! Should never ever get here
|
||||
info = -1
|
||||
end select
|
||||
end subroutine d_parmatch_aggregator_clone
|
||||
|
||||
subroutine amg_d_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
|
||||
& op_restr,op_prol,map,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_desc_type), intent(in), target :: desc_a, desc_ac
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(psb_dspmat_type), intent(inout) :: op_prol, op_restr
|
||||
type(psb_dlinmap_type), intent(out) :: map
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_parmatch_aggregator_bld_map'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
!
|
||||
! Copy the prolongation/restriction matrices into the descriptor map.
|
||||
! op_restr => PR^T i.e. restriction operator
|
||||
! op_prol => PR i.e. prolongation operator
|
||||
!
|
||||
! For parmatch have an explicit copy of the descriptors
|
||||
!
|
||||
if (allocated(ag%desc_ax)) then
|
||||
!!$ write(0,*) 'Building linmap with ag%desc_ax ',ag%desc_ax%get_local_rows(),ag%desc_ax%get_local_cols(),&
|
||||
!!$ & desc_ac%get_local_rows(),desc_ac%get_local_cols()
|
||||
map = psb_linmap(psb_map_gen_linear_,ag%desc_ax,&
|
||||
& desc_ac,op_restr,op_prol,ilaggr,nlaggr)
|
||||
else
|
||||
map = psb_linmap(psb_map_gen_linear_,desc_a,&
|
||||
& desc_ac,op_restr,op_prol,ilaggr,nlaggr)
|
||||
end if
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_d_parmatch_aggregator_bld_map
|
||||
|
||||
end module amg_d_parmatch_aggregator_mod
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,713 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from amg4psblas-extension
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! The aggregator object hosts the aggregation method for building
|
||||
! the multilevel hierarchy. This variant is based on the hybrid method
|
||||
! presented in
|
||||
!
|
||||
!
|
||||
! sm - class(amg_T_base_smoother_type), allocatable
|
||||
! The current level preconditioner (aka smoother).
|
||||
! parms - type(amg_RTml_parms)
|
||||
! The parameters defining the multilevel strategy.
|
||||
! ac - The local part of the current-level matrix, built by
|
||||
! coarsening the previous-level matrix.
|
||||
! desc_ac - type(psb_desc_type).
|
||||
! The communication descriptor associated to the matrix
|
||||
! stored in ac.
|
||||
! base_a - type(psb_Tspmat_type), pointer.
|
||||
! Pointer (really a pointer!) to the local part of the current
|
||||
! matrix (so we have a unified treatment of residuals).
|
||||
! We need this to avoid passing explicitly the current matrix
|
||||
! to the routine which applies the preconditioner.
|
||||
! base_desc - type(psb_desc_type), pointer.
|
||||
! Pointer to the communication descriptor associated to the
|
||||
! matrix pointed by base_a.
|
||||
! map - Stores the maps (restriction and prolongation) between the
|
||||
! vector spaces associated to the index spaces of the previous
|
||||
! and current levels.
|
||||
!
|
||||
! Methods:
|
||||
! Most methods follow the encapsulation hierarchy: they take whatever action
|
||||
! is appropriate for the current object, then call the corresponding method for
|
||||
! the contained object.
|
||||
! As an example: the descr() method prints out a description of the
|
||||
! level. It starts by invoking the descr() method of the parms object,
|
||||
! then calls the descr() method of the smoother object.
|
||||
!
|
||||
! descr - Prints a description of the object.
|
||||
! default - Set default values
|
||||
! dump - Dump to file object contents
|
||||
! set - Sets various parameters; when a request is unknown
|
||||
! it is passed to the smoother object for further processing.
|
||||
! check - Sanity checks.
|
||||
! sizeof - Total memory occupation in bytes
|
||||
! get_nzeros - Number of nonzeros
|
||||
!
|
||||
!
|
||||
|
||||
module amg_s_parmatch_aggregator_mod
|
||||
use amg_s_base_aggregator_mod
|
||||
use smatchboxp_mod
|
||||
|
||||
type, extends(amg_s_base_aggregator_type) :: amg_s_parmatch_aggregator_type
|
||||
integer(psb_ipk_) :: matching_alg
|
||||
integer(psb_ipk_) :: n_sweeps ! When n_sweeps >1 we need an auxiliary descriptor
|
||||
integer(psb_ipk_) :: orig_aggr_size
|
||||
integer(psb_ipk_) :: jacobi_sweeps
|
||||
real(psb_spk_), allocatable :: w(:), w_nxt(:)
|
||||
type(psb_sspmat_type), allocatable :: prol, restr
|
||||
type(psb_sspmat_type), allocatable :: ac, base_a, rwa
|
||||
type(psb_desc_type), allocatable :: desc_ac, desc_ax, base_desc, rwdesc
|
||||
integer(psb_ipk_) :: max_csize
|
||||
integer(psb_ipk_) :: max_nlevels
|
||||
logical :: reproducible_matching = .false.
|
||||
logical :: need_symmetrize = .false.
|
||||
logical :: unsmoothed_hierarchy = .true.
|
||||
contains
|
||||
procedure, pass(ag) :: bld_tprol => amg_s_parmatch_aggregator_build_tprol
|
||||
procedure, pass(ag) :: mat_bld => amg_s_parmatch_aggregator_mat_bld
|
||||
procedure, pass(ag) :: mat_asb => amg_s_parmatch_aggregator_mat_asb
|
||||
procedure, pass(ag) :: inner_mat_asb => amg_s_parmatch_aggregator_inner_mat_asb
|
||||
procedure, pass(ag) :: bld_map => amg_s_parmatch_aggregator_bld_map
|
||||
procedure, pass(ag) :: csetc => s_parmatch_aggr_csetc
|
||||
procedure, pass(ag) :: cseti => s_parmatch_aggr_cseti
|
||||
procedure, pass(ag) :: default => s_parmatch_aggr_set_default
|
||||
procedure, pass(ag) :: sizeof => s_parmatch_aggregator_sizeof
|
||||
procedure, pass(ag) :: update_next => s_parmatch_aggregator_update_next
|
||||
procedure, pass(ag) :: bld_wnxt => s_parmatch_bld_wnxt
|
||||
procedure, pass(ag) :: bld_default_w => s_bld_default_w
|
||||
procedure, pass(ag) :: set_c_default_w => s_set_prm_c_default_w
|
||||
procedure, pass(ag) :: descr => s_parmatch_aggregator_descr
|
||||
procedure, pass(ag) :: clone => s_parmatch_aggregator_clone
|
||||
procedure, pass(ag) :: free => s_parmatch_aggregator_free
|
||||
procedure, nopass :: fmt => s_parmatch_aggregator_fmt
|
||||
procedure, nopass :: xt_desc => amg_s_parmatch_aggregator_xt_desc
|
||||
end type amg_s_parmatch_aggregator_type
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine glob_transpose(ain,desc_r,desc_c,atrans,desc_rx,info)
|
||||
!!$ import :: psb_desc_type, psb_ld_coo_sparse_mat, psb_ipk_
|
||||
!!$ implicit none
|
||||
!!$ type(psb_ld_coo_sparse_mat), intent(in) :: ain
|
||||
!!$ type(psb_ld_coo_sparse_mat), intent(out) :: atrans
|
||||
!!$ type(psb_desc_type), intent(inout) :: desc_r, desc_c
|
||||
!!$ type(psb_desc_type), intent(out) :: desc_rx
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ end subroutine glob_transpose
|
||||
!!$ end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
& a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(amg_saggr_data), intent(in) :: ag_data
|
||||
type(psb_sspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
|
||||
type(psb_lsspmat_type), intent(out) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_aggregator_build_tprol
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_aggregator_mat_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_aggregator_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
type(psb_sspmat_type), intent(inout) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_aggregator_mat_asb
|
||||
end interface
|
||||
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_aggregator_inner_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
type(psb_sspmat_type), intent(inout) :: op_prol,op_restr
|
||||
type(psb_sspmat_type), intent(inout) :: ac
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_aggregator_inner_mat_asb
|
||||
end interface
|
||||
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(inout) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_spmm_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_unsmth_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_smth_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
|
||||
implicit none
|
||||
type(psb_sspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_spmm_bld_ov
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_parmatch_spmm_bld_inner(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
|
||||
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data,&
|
||||
& psb_s_csr_sparse_mat, psb_ls_csr_sparse_mat
|
||||
implicit none
|
||||
type(psb_s_csr_sparse_mat), intent(inout) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_parmatch_spmm_bld_inner
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ Subroutine amg_d_p_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data)
|
||||
!!$ import
|
||||
!!$ Implicit None
|
||||
!!$ type(psb_ld_csr_sparse_mat),intent(in) :: acsr
|
||||
!!$ type(psb_ld_csr_sparse_mat),intent(inout) :: bcsr
|
||||
!!$ type(psb_ld_csr_sparse_mat),intent(out) :: ccsr
|
||||
!!$ type(psb_desc_type),intent(in) :: desc_a
|
||||
!!$ type(psb_desc_type),intent(inout) :: desc_c
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ integer(psb_ipk_), intent(in), optional :: data
|
||||
!!$ end Subroutine amg_d_p_csr_spspmm
|
||||
!!$ end interface
|
||||
|
||||
private :: is_legal_malg, is_legal_csize, is_legal_nsweeps, is_legal_nlevels
|
||||
|
||||
contains
|
||||
|
||||
subroutine s_bld_default_w(ag,nr)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
integer(psb_ipk_), intent(in) :: nr
|
||||
integer(psb_ipk_) :: info
|
||||
call psb_realloc(nr,ag%w,info)
|
||||
if (info /= psb_success_) return
|
||||
ag%w = done
|
||||
!call ag%set_c_default_w()
|
||||
end subroutine s_bld_default_w
|
||||
|
||||
subroutine s_set_prm_c_default_w(ag)
|
||||
use psb_realloc_mod
|
||||
use iso_c_binding
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
!write(0,*) 'prm_c_deafult_w '
|
||||
call psb_safe_ab_cpy(ag%w,ag%w_nxt,info)
|
||||
|
||||
end subroutine s_set_prm_c_default_w
|
||||
|
||||
subroutine s_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
integer(psb_lpk_), intent(in) :: ilaggr(:)
|
||||
real(psb_spk_), intent(in) :: valaggr(:)
|
||||
integer(psb_ipk_), intent(in) :: nx
|
||||
|
||||
integer(psb_ipk_) :: info,i,j
|
||||
|
||||
! The vector was already fixed in the call to BCMatch.
|
||||
!write(0,*) 'Executing bld_wnxt ',nx
|
||||
call psb_realloc(nx,ag%w_nxt,info)
|
||||
|
||||
end subroutine s_parmatch_bld_wnxt
|
||||
|
||||
function s_parmatch_aggregator_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Parallel Matching aggregation"
|
||||
end function s_parmatch_aggregator_fmt
|
||||
|
||||
function amg_s_parmatch_aggregator_xt_desc() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function amg_s_parmatch_aggregator_xt_desc
|
||||
|
||||
function s_parmatch_aggregator_sizeof(ag) result(val)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), intent(in) :: ag
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = 4
|
||||
val = val + psb_size(ag%w) + psb_size(ag%w_nxt)
|
||||
if (allocated(ag%ac)) val = val + ag%ac%sizeof()
|
||||
if (allocated(ag%base_a)) val = val + ag%base_a%sizeof()
|
||||
if (allocated(ag%prol)) val = val + ag%prol%sizeof()
|
||||
if (allocated(ag%restr)) val = val + ag%restr%sizeof()
|
||||
if (allocated(ag%desc_ac)) val = val + ag%desc_ac%sizeof()
|
||||
if (allocated(ag%base_desc)) val = val + ag%base_desc%sizeof()
|
||||
if (allocated(ag%desc_ax)) val = val + ag%desc_ax%sizeof()
|
||||
|
||||
end function s_parmatch_aggregator_sizeof
|
||||
|
||||
subroutine s_parmatch_aggregator_descr(ag,parms,iout,info)
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), intent(in) :: ag
|
||||
type(amg_sml_parms), intent(in) :: parms
|
||||
integer(psb_ipk_), intent(in) :: iout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
write(iout,*) 'Parallel Matching Aggregator'
|
||||
write(iout,*) ' Number of matching sweeps: ',ag%n_sweeps
|
||||
write(iout,*) ' Matching algorithm : MatchBoxP (PREIS)'
|
||||
write(iout,*) 'Aggregator object type: ',ag%fmt()
|
||||
call parms%mldescr(iout,info)
|
||||
|
||||
return
|
||||
end subroutine s_parmatch_aggregator_descr
|
||||
|
||||
function is_legal_malg(alg) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: alg
|
||||
|
||||
val = (0==alg)
|
||||
end function is_legal_malg
|
||||
|
||||
function is_legal_csize(csize) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: csize
|
||||
|
||||
val = ((-1==csize).or.(csize >0))
|
||||
end function is_legal_csize
|
||||
|
||||
function is_legal_nsweeps(nsw) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: nsw
|
||||
|
||||
val = (1<=nsw)
|
||||
end function is_legal_nsweeps
|
||||
|
||||
function is_legal_nlevels(nlv) result(val)
|
||||
logical :: val
|
||||
integer(psb_ipk_) :: nlv
|
||||
|
||||
val = (1<=nlv)
|
||||
end function is_legal_nlevels
|
||||
|
||||
|
||||
subroutine s_parmatch_aggregator_update_next(ag,agnext,info)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
class(amg_s_base_aggregator_type), target, intent(inout) :: agnext
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
!
|
||||
!
|
||||
select type(agnext)
|
||||
class is (amg_s_parmatch_aggregator_type)
|
||||
if (.not.is_legal_malg(agnext%matching_alg)) &
|
||||
& agnext%matching_alg = ag%matching_alg
|
||||
if (.not.is_legal_nsweeps(agnext%n_sweeps))&
|
||||
& agnext%n_sweeps = ag%n_sweeps
|
||||
if (.not.is_legal_csize(agnext%max_csize))&
|
||||
& agnext%max_csize = ag%max_csize
|
||||
if (.not.is_legal_nlevels(agnext%max_nlevels))&
|
||||
& agnext%max_nlevels = ag%max_nlevels
|
||||
! Is this going to generate shallow copies/memory leaks/double frees?
|
||||
! To be investigated further.
|
||||
call psb_safe_ab_cpy(ag%w_nxt,agnext%w,info)
|
||||
call agnext%set_c_default_w()
|
||||
if (ag%unsmoothed_hierarchy) then
|
||||
agnext%unsmoothed_hierarchy = .true.
|
||||
call move_alloc(ag%rwdesc,agnext%base_desc)
|
||||
call move_alloc(ag%rwa,agnext%base_a)
|
||||
end if
|
||||
|
||||
class default
|
||||
! What should we do here?
|
||||
end select
|
||||
info = 0
|
||||
end subroutine s_parmatch_aggregator_update_next
|
||||
|
||||
subroutine s_parmatch_aggr_csetc(ag,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, iwhat
|
||||
character(len=20) :: name='s_parmatch_aggr_cseti'
|
||||
info = psb_success_
|
||||
|
||||
! For now we ignore IDX
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('PRMC_REPRODUCIBLE_MATCHING')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('F','FALSE')
|
||||
ag%reproducible_matching = .false.
|
||||
case('REPRODUCIBLE','TRUE','T')
|
||||
ag%reproducible_matching =.true.
|
||||
end select
|
||||
case('PRMC_NEED_SYMMETRIZE')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('FALSE','F')
|
||||
ag%need_symmetrize = .false.
|
||||
case('SYMMETRIZE','TRUE','T')
|
||||
ag%need_symmetrize =.true.
|
||||
end select
|
||||
case('PRMC_UNSMOOTHED_HIERARCHY')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('F','FALSE')
|
||||
ag%unsmoothed_hierarchy = .false.
|
||||
case('T','TRUE')
|
||||
ag%unsmoothed_hierarchy =.true.
|
||||
end select
|
||||
case default
|
||||
! Do nothing
|
||||
end select
|
||||
return
|
||||
end subroutine s_parmatch_aggr_csetc
|
||||
|
||||
subroutine s_parmatch_aggr_cseti(ag,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, iwhat
|
||||
character(len=20) :: name='s_parmatch_aggr_cseti'
|
||||
info = psb_success_
|
||||
|
||||
! For now we ignore IDX
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('PRMC_MATCH_ALG')
|
||||
ag%matching_alg=val
|
||||
case('PRMC_SWEEPS')
|
||||
ag%n_sweeps=val
|
||||
case('AGGR_SIZE')
|
||||
ag%orig_aggr_size = val
|
||||
ag%n_sweeps=max(1,ceiling(log(val*1.0)/log(2.0)))
|
||||
case('PRMC_MAX_CSIZE')
|
||||
ag%max_csize=val
|
||||
case('PRMC_MAX_NLEVELS')
|
||||
ag%max_nlevels=val
|
||||
case('PRMC_W_SIZE')
|
||||
call ag%bld_default_w(val)
|
||||
case('PRMC_REPRODUCIBLE_MATCHING')
|
||||
ag%reproducible_matching = (val == 1)
|
||||
case('PRMC_NEED_SYMMETRIZE')
|
||||
ag%need_symmetrize = (val == 1)
|
||||
case('PRMC_UNSMOOTHED_HIERARCHY')
|
||||
ag%unsmoothed_hierarchy = (val == 1)
|
||||
case default
|
||||
! Do nothing
|
||||
end select
|
||||
return
|
||||
end subroutine s_parmatch_aggr_cseti
|
||||
|
||||
subroutine s_parmatch_aggr_set_default(ag)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
|
||||
character(len=20) :: name='s_parmatch_aggr_set_default'
|
||||
ag%matching_alg = 0
|
||||
ag%n_sweeps = 1
|
||||
ag%jacobi_sweeps = 0
|
||||
ag%max_nlevels = 36
|
||||
ag%max_csize = -1
|
||||
!
|
||||
! Apparently BootCMatch works better
|
||||
! by keeping all entries
|
||||
!
|
||||
ag%do_clean_zeros = .false.
|
||||
|
||||
return
|
||||
|
||||
end subroutine s_parmatch_aggr_set_default
|
||||
|
||||
subroutine s_parmatch_aggregator_free(ag,info)
|
||||
use iso_c_binding
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if ((info == 0).and.allocated(ag%w)) deallocate(ag%w,stat=info)
|
||||
if ((info == 0).and.allocated(ag%w_nxt)) deallocate(ag%w_nxt,stat=info)
|
||||
if ((info == 0).and.allocated(ag%prol)) then
|
||||
call ag%prol%free(); deallocate(ag%prol,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%restr)) then
|
||||
call ag%restr%free(); deallocate(ag%restr,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%ac)) then
|
||||
call ag%ac%free(); deallocate(ag%ac,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%base_a)) then
|
||||
call ag%base_a%free(); deallocate(ag%base_a,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%rwa)) then
|
||||
call ag%rwa%free(); deallocate(ag%rwa,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%desc_ac)) then
|
||||
call ag%desc_ac%free(info); deallocate(ag%desc_ac,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%desc_ax)) then
|
||||
call ag%desc_ax%free(info); deallocate(ag%desc_ax,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%base_desc)) then
|
||||
call ag%base_desc%free(info); deallocate(ag%base_desc,stat=info)
|
||||
end if
|
||||
if ((info == 0).and.allocated(ag%rwdesc)) then
|
||||
call ag%rwdesc%free(info); deallocate(ag%rwdesc,stat=info)
|
||||
end if
|
||||
|
||||
end subroutine s_parmatch_aggregator_free
|
||||
|
||||
subroutine s_parmatch_aggregator_clone(ag,agnext,info)
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
|
||||
class(amg_s_base_aggregator_type), allocatable, intent(inout) :: agnext
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(agnext)) then
|
||||
call agnext%free(info)
|
||||
if (info == 0) deallocate(agnext,stat=info)
|
||||
end if
|
||||
if (info /= 0) return
|
||||
allocate(agnext,source=ag,stat=info)
|
||||
select type(agnext)
|
||||
class is (amg_s_parmatch_aggregator_type)
|
||||
call agnext%set_c_default_w()
|
||||
class default
|
||||
! Should never ever get here
|
||||
info = -1
|
||||
end select
|
||||
end subroutine s_parmatch_aggregator_clone
|
||||
|
||||
subroutine amg_s_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,&
|
||||
& op_restr,op_prol,map,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_desc_type), intent(in), target :: desc_a, desc_ac
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(psb_sspmat_type), intent(inout) :: op_prol, op_restr
|
||||
type(psb_slinmap_type), intent(out) :: map
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_parmatch_aggregator_bld_map'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
!
|
||||
! Copy the prolongation/restriction matrices into the descriptor map.
|
||||
! op_restr => PR^T i.e. restriction operator
|
||||
! op_prol => PR i.e. prolongation operator
|
||||
!
|
||||
! For parmatch have an explicit copy of the descriptors
|
||||
!
|
||||
if (allocated(ag%desc_ax)) then
|
||||
!!$ write(0,*) 'Building linmap with ag%desc_ax ',ag%desc_ax%get_local_rows(),ag%desc_ax%get_local_cols(),&
|
||||
!!$ & desc_ac%get_local_rows(),desc_ac%get_local_cols()
|
||||
map = psb_linmap(psb_map_gen_linear_,ag%desc_ax,&
|
||||
& desc_ac,op_restr,op_prol,ilaggr,nlaggr)
|
||||
else
|
||||
map = psb_linmap(psb_map_gen_linear_,desc_a,&
|
||||
& desc_ac,op_restr,op_prol,ilaggr,nlaggr)
|
||||
end if
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_parmatch_aggregator_bld_map
|
||||
|
||||
end module amg_s_parmatch_aggregator_mod
|
||||
@ -0,0 +1,97 @@
|
||||
// ***********************************************************************
|
||||
//
|
||||
// MatchboxP: A C++ library for approximate weighted matching
|
||||
// Mahantesh Halappanavar (hala@pnnl.gov)
|
||||
// Pacific Northwest National Laboratory
|
||||
//
|
||||
// ***********************************************************************
|
||||
//
|
||||
// Copyright (2021) Battelle Memorial Institute
|
||||
// All rights reserved.
|
||||
//
|
||||
// Redistribution and use in source and binary forms, with or without
|
||||
// modification, are permitted provided that the following conditions
|
||||
// are met:
|
||||
//
|
||||
// 1. Redistributions of source code must retain the above copyright
|
||||
// notice, this list of conditions and the following disclaimer.
|
||||
//
|
||||
// 2. Redistributions in binary form must reproduce the above copyright
|
||||
// notice, this list of conditions and the following disclaimer in the
|
||||
// documentation and/or other materials provided with the distribution.
|
||||
//
|
||||
// 3. Neither the name of the copyright holder nor the names of its
|
||||
// contributors may be used to endorse or promote products derived from
|
||||
// this software without specific prior written permission.
|
||||
//
|
||||
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
||||
// FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
// COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
// INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
||||
// BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
// LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
// LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
// POSSIBILITY OF SUCH DAMAGE.
|
||||
//
|
||||
// ************************************************************************
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <mpi.h>
|
||||
|
||||
#include "MatchBoxPC.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
|
||||
void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanReal* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MilanInt icomm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
|
||||
MPI_Comm C_comm=MPI_Comm_f2c(icomm);
|
||||
#ifdef DEBUG
|
||||
fprintf(stderr,"MatchBoxPC: rank %d nlver %ld nledge %ld [ %ld %ld ]\n",
|
||||
myRank,NLVer, NLEdge,verDistance[0],verDistance[1]);
|
||||
#endif
|
||||
dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
|
||||
verLocPtr, verLocInd, edgeLocWeight,
|
||||
verDistance, Mate,
|
||||
myRank, numProcs, C_comm,
|
||||
msgIndSent, msgActualSent, msgPercent,
|
||||
ph0_time, ph1_time, ph2_time,
|
||||
ph1_card, ph2_card );
|
||||
}
|
||||
|
||||
void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanFloat* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MilanInt icomm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
|
||||
MPI_Comm C_comm=MPI_Comm_f2c(icomm);
|
||||
#ifdef DEBUG
|
||||
fprintf(stderr,"MatchBoxPC: rank %d nlver %ld nledge %ld [ %ld %ld ]\n",
|
||||
myRank,NLVer, NLEdge,verDistance[0],verDistance[1]);
|
||||
#endif
|
||||
salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
|
||||
verLocPtr, verLocInd, edgeLocWeight,
|
||||
verDistance, Mate,
|
||||
myRank, numProcs, C_comm,
|
||||
msgIndSent, msgActualSent, msgPercent,
|
||||
ph0_time, ph1_time, ph2_time,
|
||||
ph1_card, ph2_card );
|
||||
}
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
@ -0,0 +1,178 @@
|
||||
// ***********************************************************************
|
||||
//
|
||||
// MatchboxP: A C++ library for approximate weighted matching
|
||||
// Mahantesh Halappanavar (hala@pnnl.gov)
|
||||
// Pacific Northwest National Laboratory
|
||||
//
|
||||
// ***********************************************************************
|
||||
//
|
||||
// Copyright (2021) Battelle Memorial Institute
|
||||
// All rights reserved.
|
||||
//
|
||||
// Redistribution and use in source and binary forms, with or without
|
||||
// modification, are permitted provided that the following conditions
|
||||
// are met:
|
||||
//
|
||||
// 1. Redistributions of source code must retain the above copyright
|
||||
// notice, this list of conditions and the following disclaimer.
|
||||
//
|
||||
// 2. Redistributions in binary form must reproduce the above copyright
|
||||
// notice, this list of conditions and the following disclaimer in the
|
||||
// documentation and/or other materials provided with the distribution.
|
||||
//
|
||||
// 3. Neither the name of the copyright holder nor the names of its
|
||||
// contributors may be used to endorse or promote products derived from
|
||||
// this software without specific prior written permission.
|
||||
//
|
||||
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
||||
// FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
// COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
// INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
||||
// BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
// LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
// LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
// POSSIBILITY OF SUCH DAMAGE.
|
||||
//
|
||||
// ************************************************************************
|
||||
|
||||
/*
|
||||
Feature: Message Aggregation:
|
||||
Request messages from the Initialization phase are aggregated and only
|
||||
one message per processor is sent.
|
||||
Data structures for message aggregation are similar to the data structures
|
||||
for storing compressed matrices/graphs - Pointers + actual messages.
|
||||
Assumption: processor indices are numbered from zero to P-1.
|
||||
*/
|
||||
|
||||
/* Special feature: Mate is proportional to the size of local number of verices */
|
||||
|
||||
#ifndef _matchboxpC_H_
|
||||
#define _matchboxpC_H_
|
||||
//Turn on a lot of debugging information with this switch:
|
||||
//#define PRINT_DEBUG_INFO_
|
||||
#include <stdio.h>
|
||||
#include <iostream>
|
||||
#include <assert.h>
|
||||
#include <map>
|
||||
#include <vector>
|
||||
// #include "matchboxp.h"
|
||||
#include "primitiveDataTypeDefinitions.h"
|
||||
#include "dataStrStaticQueue.h"
|
||||
|
||||
using namespace std;
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#define MilanMpiLongInt MPI_LONG_LONG
|
||||
|
||||
#ifndef _primitiveDataType_Definition_
|
||||
#define _primitiveDataType_Definition_
|
||||
//Regular integer:
|
||||
#ifndef INTEGER_H
|
||||
#define INTEGER_H
|
||||
typedef int32_t MilanInt;
|
||||
#endif
|
||||
|
||||
//Regular long integer:
|
||||
#ifndef LONG_INT_H
|
||||
#define LONG_INT_H
|
||||
#ifdef BIT64
|
||||
typedef int64_t MilanLongInt;
|
||||
typedef MPI_LONG MilanMpiLongInt;
|
||||
#else
|
||||
typedef int32_t MilanLongInt;
|
||||
typedef MPI_INT MilanMpiLongInt;
|
||||
#endif
|
||||
#endif
|
||||
|
||||
//Regular boolean
|
||||
#ifndef BOOL_H
|
||||
#define BOOL_H
|
||||
typedef bool MilanBool;
|
||||
#endif
|
||||
|
||||
//Regular double and absolute value computation:
|
||||
#ifndef REAL_H
|
||||
#define REAL_H
|
||||
typedef double MilanReal;
|
||||
typedef MPI_DOUBLE MilanMpiReal;
|
||||
inline MilanReal MilanAbs(MilanReal value)
|
||||
{
|
||||
return fabs(value);
|
||||
}
|
||||
#endif
|
||||
|
||||
//Regular float and absolute value computation:
|
||||
#ifndef FLOAT_H
|
||||
#define FLOAT_H
|
||||
typedef float MilanFloat;
|
||||
typedef MPI_FLOAT MilanMpiFloat;
|
||||
inline MilanFloat MilanAbsFloat(MilanFloat value)
|
||||
{
|
||||
return fabs(value);
|
||||
}
|
||||
#endif
|
||||
|
||||
//// Define the limits:
|
||||
#ifndef LIMITS_H
|
||||
#define LIMITS_H
|
||||
//Integer Maximum and Minimum:
|
||||
// #define MilanIntMax INT_MAX
|
||||
// #define MilanIntMin INT_MIN
|
||||
#define MilanIntMax INT32_MAX
|
||||
#define MilanIntMin INT32_MIN
|
||||
|
||||
#ifdef BIT64
|
||||
#define MilanLongIntMax INT64_MAX
|
||||
#define MilanLongIntMin -INT64_MAX
|
||||
#else
|
||||
#define MilanLongIntMax INT32_MAX
|
||||
#define MilanLongIntMin -INT32_MAX
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
||||
// +INFINITY
|
||||
const double PLUS_INFINITY = numeric_limits<int>::infinity();
|
||||
const double MINUS_INFINITY = -PLUS_INFINITY;
|
||||
//#define MilanRealMax LDBL_MAX
|
||||
#define MilanRealMax PLUS_INFINITY
|
||||
#define MilanRealMin MINUS_INFINITY
|
||||
#endif
|
||||
|
||||
//Function of find the owner of a ghost vertex using binary search:
|
||||
inline MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
|
||||
MilanInt myRank, MilanInt numProcs);
|
||||
|
||||
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC
|
||||
(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanReal* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card );
|
||||
|
||||
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC
|
||||
(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanFloat* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card );
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,231 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_d_parmatch_aggregator_mat_asb.f90
|
||||
!
|
||||
! Subroutine: amg_d_parmatch_aggregator_mat_asb
|
||||
! Version: real
|
||||
!
|
||||
!
|
||||
! From a given AC to final format, generating DESC_AC.
|
||||
! This is quite involved, because in the context of aggregation based
|
||||
! on parallel matching we are building the matrix hierarchy within BLD_TPROL
|
||||
! as we go, especially if we have multiple sweeps, hence this code is called
|
||||
! in two completely different contexts:
|
||||
! 1. Within bld_tprol for the internal hierarchy
|
||||
! 2. Outside, from amg_hierarchy_bld
|
||||
! The solution we have found is for bld_tprol to copy its output
|
||||
! into special components ag%ac ag%desc_ac etc so that:
|
||||
! 1. if they are allocated, it means that bld_tprol has been already invoked, we are in
|
||||
! amg_hierarchy_bld and we only need to copy them
|
||||
! 2. If they are not allocated, we are within bld_tprol, and we need to actually
|
||||
! perform the various needed steps.
|
||||
!
|
||||
! Arguments:
|
||||
! ag - type(amg_d_parmatch_aggregator_type), input/output.
|
||||
! The aggregator object
|
||||
! parms - type(amg_dml_parms), input
|
||||
! The aggregation parameters
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! ac - type(psb_dspmat_type), inout
|
||||
! The coarse matrix
|
||||
! desc_ac - type(psb_desc_type), output.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
!
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), input/output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_d_parmatch_aggregator_inner_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_aggregator_inner_mat_asb
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
type(psb_dspmat_type), intent(inout) :: op_prol,op_restr
|
||||
type(psb_dspmat_type), intent(inout) :: ac
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
type(psb_ld_coo_sparse_mat) :: acoo, bcoo
|
||||
type(psb_ld_csr_sparse_mat) :: acsr1
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: err_act, debug_level, debug_unit
|
||||
character(len=20) :: name='d_parmatch_inner_mat_asb'
|
||||
character(len=80) :: aname
|
||||
logical, parameter :: debug=.false., dump_prol_restr=.false.
|
||||
|
||||
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' Start:',&
|
||||
& allocated(ag%ac),allocated(ag%desc_ac), allocated(ag%prol),allocated(ag%restr)
|
||||
|
||||
|
||||
select case(parms%coarse_mat)
|
||||
|
||||
case(amg_distr_mat_)
|
||||
! Do nothing, it has already been done in spmm_bld_ov.
|
||||
|
||||
case(amg_repl_mat_)
|
||||
!
|
||||
!
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='no repl coarse_mat_ here')
|
||||
goto 9999
|
||||
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
|
||||
end subroutine amg_d_parmatch_aggregator_inner_mat_asb
|
||||
@ -0,0 +1,277 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_d_base_aggregator_mat_bld.f90
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_d_parmatch_aggregator_mat_asb.f90
|
||||
!
|
||||
! Subroutine: amg_d_parmatch_aggregator_mat_asb
|
||||
! Version: real
|
||||
!
|
||||
!
|
||||
! From a given AC to final format, generating DESC_AC.
|
||||
! This is quite involved, because in the context of aggregation based
|
||||
! on parallel matching we are building the matrix hierarchy within BLD_TPROL
|
||||
! as we go, especially if we have multiple sweeps, hence this code is called
|
||||
! in two completely different contexts:
|
||||
! 1. Within bld_tprol for the internal hierarchy
|
||||
! 2. Outside, from amg_hierarchy_bld
|
||||
! The solution we have found is for bld_tprol to copy its output
|
||||
! into special components ag%ac ag%desc_ac etc so that:
|
||||
! 1. if they are allocated, it means that bld_tprol has been already invoked, we are in
|
||||
! amg_hierarchy_bld and we only need to copy them
|
||||
! 2. If they are not allocated, we are within bld_tprol, and we need to actually
|
||||
! perform the various needed steps.
|
||||
!
|
||||
! Arguments:
|
||||
! ag - type(amg_d_parmatch_aggregator_type), input/output.
|
||||
! The aggregator object
|
||||
! parms - type(amg_dml_parms), input
|
||||
! The aggregation parameters
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! ac - type(psb_dspmat_type), inout
|
||||
! The coarse matrix
|
||||
! desc_ac - type(psb_desc_type), output.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
!
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), input/output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_d_parmatch_aggregator_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_aggregator_mat_asb
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
type(psb_ld_coo_sparse_mat) :: tmpcoo
|
||||
type(psb_ldspmat_type) :: tmp_ac
|
||||
integer(psb_ipk_) :: i_nr, i_nc, i_nl, nzl
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: err_act, debug_level, debug_unit
|
||||
character(len=20) :: name='d_parmatch_mat_asb'
|
||||
character(len=80) :: aname
|
||||
logical, parameter :: debug=.false., dump_prol_restr=.false., dump_ac=.false.
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
if (psb_get_errstatus().ne.0) then
|
||||
write(0,*) me,' From:',trim(name),':',psb_get_errstatus()
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' Start:',&
|
||||
& allocated(ag%ac),allocated(ag%desc_ac), allocated(ag%prol),allocated(ag%restr)
|
||||
|
||||
select case(parms%coarse_mat)
|
||||
|
||||
case(amg_distr_mat_)
|
||||
|
||||
call ac%cscnv(info,type='csr')
|
||||
call op_prol%cscnv(info,type='csr')
|
||||
call op_restr%cscnv(info,type='csr')
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done ac '
|
||||
|
||||
case(amg_repl_mat_)
|
||||
!
|
||||
! We are assuming here that an d matrix
|
||||
! can hold all entries
|
||||
!
|
||||
if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then
|
||||
ntaggr = desc_ac%get_global_rows()
|
||||
i_nr = ntaggr
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call op_prol%mv_to(tmpcoo)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
|
||||
call op_prol%mv_from(tmpcoo)
|
||||
|
||||
call op_restr%mv_to(tmpcoo)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
|
||||
call op_restr%mv_from(tmpcoo)
|
||||
|
||||
call op_prol%set_ncols(i_nr)
|
||||
call op_restr%set_nrows(i_nr)
|
||||
|
||||
call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
|
||||
& dupl=psb_dupl_add_,keeploc=.false.)
|
||||
call tmp_ac%mv_to(tmpcoo)
|
||||
call ac%mv_from(tmpcoo)
|
||||
|
||||
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
|
||||
if (info == psb_success_) call psb_cdasb(desc_ac,info)
|
||||
!
|
||||
! Now that we have the descriptors and the restrictor, we should
|
||||
! update the W. But we don't, because REPL is only valid
|
||||
! at the coarsest level, so no need to carry over.
|
||||
!
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
|
||||
end subroutine amg_d_parmatch_aggregator_mat_asb
|
||||
@ -0,0 +1,275 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_d_base_aggregator_mat_bld.f90
|
||||
!
|
||||
! Subroutine: amg_d_base_aggregator_mat_bld
|
||||
! Version: d
|
||||
!
|
||||
! This routine builds the matrix associated to the current level of the
|
||||
! multilevel preconditioner from the matrix associated to the previous level,
|
||||
! by using the user-specified aggregation technique (therefore, it also builds the
|
||||
! prolongation and restriction operators mapping the current level to the
|
||||
! previous one and vice versa).
|
||||
! The current level is regarded as the coarse one, while the previous as
|
||||
! the fine one. This is in agreement with the fact that the routine is called,
|
||||
! by amg_mlprec_bld, only on levels >=2.
|
||||
! The coarse-level matrix A_C is built from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is a prolongator from the coarse level to the fine one.
|
||||
!
|
||||
! A mapping from the nodes of the adjacency graph of A to the nodes of the
|
||||
! adjacency graph of A_C has been computed by the amg_aggrmap_bld subroutine.
|
||||
! The prolongator P_C is built here from this mapping, according to the
|
||||
! value of p%iprcparm(amg_aggr_kind_), specified by the user through
|
||||
! amg_dprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
! amg_d_lev_aggrmat_bld.
|
||||
!
|
||||
! Currently four different prolongators are implemented, corresponding to
|
||||
! four aggregation algorithms:
|
||||
! 1. un-smoothed aggregation,
|
||||
! 2. smoothed aggregation,
|
||||
! 3. "bizarre" aggregation.
|
||||
! 4. minimum energy
|
||||
! 1. The non-smoothed aggregation uses as prolongator the piecewise constant
|
||||
! interpolation operator corresponding to the fine-to-coarse level mapping built
|
||||
! by p%aggr%bld_tprol. This is called tentative prolongator.
|
||||
! 2. The smoothed aggregation uses as prolongator the operator obtained by applying
|
||||
! a damped Jacobi smoother to the tentative prolongator.
|
||||
! 3. The "bizarre" aggregation uses a prolongator proposed by the authors of AMG4PSBLAS.
|
||||
! This prolongator still requires a deep analysis and testing and its use is
|
||||
! not recommended.
|
||||
! 4. Minimum energy aggregation
|
||||
!
|
||||
! For more details see
|
||||
! M. Brezina and P. Vanek, A black-box iterative solver based on a two-level
|
||||
! Schwarz method, Computing, 63 (1999), 233-263.
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of PSBLAS-based
|
||||
! parallel two-level Schwarz preconditioners, Appl. Num. Math., 57 (2007),
|
||||
! 1181-1196.
|
||||
! M. Sala, R. Tuminaro: A new Petrov-Galerkin smoothed aggregation preconditioner
|
||||
! for nonsymmetric linear systems, SIAM J. Sci. Comput., 31(1):143-166 (2008)
|
||||
!
|
||||
!
|
||||
! The main structure is:
|
||||
! 1. Perform sanity checks;
|
||||
! 2. Compute prolongator/restrictor/AC
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! ag - type(amg_d_base_aggregator_type), input/output.
|
||||
! The aggregator object
|
||||
! parms - type(amg_dml_parms), input
|
||||
! The aggregation parameters
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! ac - type(psb_dspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_d_parmatch_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_d_inner_mod
|
||||
use amg_d_prec_type
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_aggregator_mat_bld
|
||||
implicit none
|
||||
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
character(len=20) :: name
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
type(psb_dspmat_type) :: atmp
|
||||
|
||||
name='d_parmatch_mat_bld'
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by
|
||||
!
|
||||
|
||||
call clean_shortcuts(ag)
|
||||
!
|
||||
! When requesting smoothed aggregation we cannot use the
|
||||
! unsmoothed shortcuts
|
||||
!
|
||||
select case (parms%aggr_prol)
|
||||
case (amg_no_smooth_)
|
||||
call amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
|
||||
case(amg_smooth_prol_)
|
||||
call amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
|
||||
!!$ case(amg_biz_prol_)
|
||||
!!$ call amg_daggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
|
||||
!!$ & parms,ac,desc_ac,op_prol,op_restr,info)
|
||||
|
||||
case(amg_min_energy_)
|
||||
call amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
|
||||
& parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Invalid aggr kind')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
subroutine clean_shortcuts(ag)
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
|
||||
integer(psb_ipk_) :: info
|
||||
if (allocated(ag%prol)) then
|
||||
call ag%prol%free()
|
||||
deallocate(ag%prol)
|
||||
end if
|
||||
if (allocated(ag%restr)) then
|
||||
call ag%restr%free()
|
||||
deallocate(ag%restr)
|
||||
end if
|
||||
if (ag%unsmoothed_hierarchy) then
|
||||
if (allocated(ag%ac)) call move_alloc(ag%ac, ag%rwa)
|
||||
if (allocated(ag%desc_ac)) call move_alloc(ag%desc_ac,ag%rwdesc)
|
||||
else
|
||||
if (allocated(ag%ac)) then
|
||||
call ag%ac%free()
|
||||
deallocate(ag%ac)
|
||||
end if
|
||||
if (allocated(ag%desc_ac)) then
|
||||
call ag%desc_ac%free(info)
|
||||
deallocate(ag%desc_ac)
|
||||
end if
|
||||
end if
|
||||
end subroutine clean_shortcuts
|
||||
|
||||
end subroutine amg_d_parmatch_aggregator_mat_bld
|
||||
@ -0,0 +1,565 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! File: amg_d_parmatch_aggregator_tprol.f90
|
||||
!
|
||||
! Subroutine: amg_d_parmatch_aggregator_tprol
|
||||
! Version: real
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
& a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_d_prec_type
|
||||
use amg_d_inner_mod
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_aggregator_build_tprol
|
||||
use iso_c_binding
|
||||
implicit none
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(amg_daggr_data), intent(in) :: ag_data
|
||||
type(psb_dspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
|
||||
type(psb_ldspmat_type), intent(out) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
|
||||
! Local variables
|
||||
real(psb_dpk_), allocatable :: tmpw(:), tmpwnxt(:)
|
||||
integer(psb_lpk_), allocatable :: ixaggr(:), nxaggr(:), tlaggr(:), ivr(:)
|
||||
type(psb_dspmat_type) :: a_tmp
|
||||
integer(c_int) :: match_algorithm, n_sweeps, max_csize, max_nlevels
|
||||
character(len=40) :: name, ch_err
|
||||
character(len=80) :: fname, prefix_
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act, ierr
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_) :: i, j, k, nr, nc
|
||||
integer(psb_lpk_) :: isz, num_pcols, nrac, ncac, lname, nz, x_sweeps, csz
|
||||
integer(psb_lpk_) :: psz, sizes(4)
|
||||
type(psb_d_csr_sparse_mat), target :: csr_prol, csr_pvi, csr_prod_res, acsr
|
||||
type(psb_ld_csr_sparse_mat), target :: lcsr_prol
|
||||
type(psb_desc_type), allocatable :: desc_acv(:)
|
||||
type(psb_ld_coo_sparse_mat) :: tmpcoo, transp_coo
|
||||
type(psb_dspmat_type), allocatable :: acv(:)
|
||||
type(psb_dspmat_type), allocatable :: prolv(:), restrv(:)
|
||||
type(psb_ldspmat_type) :: tmp_prol, tmp_pg, tmp_restr
|
||||
type(psb_desc_type) :: tmp_desc_ac, tmp_desc_ax, tmp_desc_p
|
||||
integer(psb_ipk_), save :: idx_mboxp=-1, idx_spmmbld=-1, idx_sweeps_mult=-1
|
||||
logical, parameter :: dump=.false., do_timings=.true., debug=.false., &
|
||||
& dump_prol_restr=.false.
|
||||
|
||||
name='d_parmatch_tprol'
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
if (psb_get_errstatus().ne.0) then
|
||||
write(0,*) me,trim(name),' Err_status :',psb_get_errstatus()
|
||||
return
|
||||
end if
|
||||
if (debug) write(0,*) me,trim(name),' Start '
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
|
||||
if ((do_timings).and.(idx_mboxp==-1)) &
|
||||
& idx_mboxp = psb_get_timer_idx("PMC_TPROL: MatchBoxP")
|
||||
if ((do_timings).and.(idx_spmmbld==-1)) &
|
||||
& idx_spmmbld = psb_get_timer_idx("PMC_TPROL: spmm_bld")
|
||||
if ((do_timings).and.(idx_sweeps_mult==-1)) &
|
||||
& idx_sweeps_mult = psb_get_timer_idx("PMC_TPROL: sweeps_mult")
|
||||
|
||||
|
||||
call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
|
||||
& amg_mult_ml_,is_legal_ml_cycle)
|
||||
call amg_check_def(parms%par_aggr_alg,'Aggregation',&
|
||||
& amg_dec_aggr_,is_legal_ml_par_aggr_alg)
|
||||
call amg_check_def(parms%aggr_ord,'Ordering',&
|
||||
& amg_aggr_ord_nat_,is_legal_ml_aggr_ord)
|
||||
call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs)
|
||||
match_algorithm = ag%matching_alg
|
||||
n_sweeps = ag%n_sweeps
|
||||
if (2**n_sweeps /= ag%orig_aggr_size) then
|
||||
if (me == 0) then
|
||||
write(debug_unit, *) 'Warning: AGGR_SIZE reset to value ',2**n_sweeps
|
||||
end if
|
||||
end if
|
||||
if (ag%max_csize > 0) then
|
||||
max_csize = ag%max_csize
|
||||
else
|
||||
max_csize = ag_data%min_coarse_size
|
||||
end if
|
||||
if (ag%max_nlevels > 0) then
|
||||
max_nlevels = ag%max_nlevels
|
||||
else
|
||||
max_nlevels = ag_data%max_levs
|
||||
end if
|
||||
if (.true.) then
|
||||
block
|
||||
integer(psb_ipk_) :: ipv(2)
|
||||
ipv(1) = max_csize
|
||||
ipv(2) = n_sweeps
|
||||
call psb_bcast(ictxt,ipv)
|
||||
max_csize = ipv(1)
|
||||
n_sweeps = ipv(2)
|
||||
end block
|
||||
else
|
||||
call psb_bcast(ictxt,max_csize)
|
||||
call psb_bcast(ictxt,n_sweeps)
|
||||
end if
|
||||
if (n_sweeps /= ag%n_sweeps) then
|
||||
write(0,*) me,' Inconsistent N_SWEEPS ',n_sweeps,ag%n_sweeps
|
||||
end if
|
||||
!!$ if (me==0) write(0,*) 'Matching sweeps: ',n_sweeps
|
||||
n_sweeps = max(1,n_sweeps)
|
||||
if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,max_csize
|
||||
if (ag%unsmoothed_hierarchy.and.allocated(ag%base_a)) then
|
||||
call ag%base_a%cp_to(acsr)
|
||||
if (ag%do_clean_zeros) call acsr%clean_zeros(info)
|
||||
nr = acsr%get_nrows()
|
||||
if (psb_size(ag%w) < nr) call ag%bld_default_w(nr)
|
||||
isz = acsr%get_ncols()
|
||||
|
||||
call psb_realloc(isz,ixaggr,info)
|
||||
if (info == psb_success_) &
|
||||
& allocate(acv(0:n_sweeps), desc_acv(0:n_sweeps),&
|
||||
& prolv(n_sweeps), restrv(n_sweeps),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
end if
|
||||
|
||||
|
||||
call acv(0)%mv_from(acsr)
|
||||
call ag%base_desc%clone(desc_acv(0),info)
|
||||
|
||||
else
|
||||
call a%cp_to(acsr)
|
||||
if (ag%do_clean_zeros) call acsr%clean_zeros(info)
|
||||
nr = acsr%get_nrows()
|
||||
if (psb_size(ag%w) < nr) call ag%bld_default_w(nr)
|
||||
isz = acsr%get_ncols()
|
||||
|
||||
call psb_realloc(isz,ixaggr,info)
|
||||
if (info == psb_success_) &
|
||||
& allocate(acv(0:n_sweeps), desc_acv(0:n_sweeps),&
|
||||
& prolv(n_sweeps), restrv(n_sweeps),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
end if
|
||||
|
||||
|
||||
call acv(0)%mv_from(acsr)
|
||||
call desc_a%clone(desc_acv(0),info)
|
||||
end if
|
||||
|
||||
nrac = desc_acv(0)%get_local_rows()
|
||||
ncac = desc_acv(0)%get_local_cols()
|
||||
if (debug) write(0,*) me,' On input to level: ',nrac, ncac
|
||||
if (allocated(ag%prol)) then
|
||||
call ag%prol%free()
|
||||
deallocate(ag%prol)
|
||||
end if
|
||||
if (allocated(ag%restr)) then
|
||||
call ag%restr%free()
|
||||
deallocate(ag%restr)
|
||||
end if
|
||||
|
||||
if (dump) then
|
||||
block
|
||||
type(psb_ldspmat_type) :: lac
|
||||
ivr = desc_acv(0)%get_global_indices(owned=.false.)
|
||||
prefix_ = "input_a"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+9),'(a,i3.3,a)') '_p',me, '.mtx'
|
||||
call acv(0)%print(fname,head='Debug aggregates')
|
||||
call lac%cp_from(acv(0))
|
||||
write(fname(lname+1:lname+13),'(a,i3.3,a)') '_p',me, '-glb.mtx'
|
||||
call lac%print(fname,head='Debug aggregates',iv=ivr)
|
||||
call lac%free()
|
||||
end block
|
||||
end if
|
||||
|
||||
call psb_geall(tmpw,desc_acv(0),info)
|
||||
|
||||
tmpw(1:nr) = ag%w(1:nr)
|
||||
|
||||
call psb_geasb(tmpw,desc_acv(0),info)
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),max_csize
|
||||
end if
|
||||
|
||||
!
|
||||
! Prepare ag%ac, ag%desc_ac, ag%prol, ag%restr to enable
|
||||
! shortcuts in mat_bld and mat_asb
|
||||
! and ag%desc_ax which will be needed in backfix.
|
||||
!
|
||||
x_sweeps = -1
|
||||
sweeps_loop: do i=1, n_sweeps
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me==0) write(0,*) me,trim(name),' Start sweeps_loop iteration:',i,' of ',n_sweeps
|
||||
end if
|
||||
|
||||
!
|
||||
! Building prol and restr because this algorithm is not decoupled
|
||||
! On exit from matchbox_build_prol, prolv(i) is in global numbering
|
||||
!
|
||||
!
|
||||
if (debug) write(0,*) me,' Into matchbox_build_prol ',info
|
||||
if (do_timings) call psb_tic(idx_mboxp)
|
||||
call dmatchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,&
|
||||
& symmetrize=ag%need_symmetrize,reproducible=ag%reproducible_matching)
|
||||
if (do_timings) call psb_toc(idx_mboxp)
|
||||
if (debug) write(0,*) me,' Out from matchbox_build_prol ',info
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on exit bld_tprol',info
|
||||
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Calling spmm_bld NSW>1:',i,&
|
||||
& desc_acv(i-1)%get_local_rows(),desc_acv(i-1)%get_local_cols(),&
|
||||
& desc_acv(i-1)%get_global_rows()
|
||||
end if
|
||||
if (i == n_sweeps) call tmp_prol%clone(tmp_pg,info)
|
||||
if (do_timings) call psb_tic(idx_spmmbld)
|
||||
!
|
||||
! On entry, prolv(i) is in global numbering,
|
||||
!
|
||||
call amg_d_parmatch_spmm_bld_ov(acv(i-1),desc_acv(i-1),ixaggr,nxaggr,parms,&
|
||||
& acv(i),desc_acv(i), prolv(i),restrv(1),tmp_prol,info)
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on exit from bld_ov(i)',info
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done spmm_bld:',i
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_spmmbld)
|
||||
! Keep a copy of prolv(i) in global numbering for the time being, will
|
||||
! need it to build the final
|
||||
! if (i == n_sweeps) call prolv(i)%clone(tmp_prol,info)
|
||||
!!$ write(0,*) name,' Call mat_asb sweep:',i,n_sweeps
|
||||
call ag%inner_mat_asb(parms,acv(i-1),desc_acv(i-1),&
|
||||
& acv(i),desc_acv(i),prolv(i),restrv(1),info)
|
||||
|
||||
!!$ write(0,*) me,' From in_mat_asb:',&
|
||||
!!$ & prolv(i)%get_nrows(),prolv(i)%get_ncols(),&
|
||||
!!$ & restrv(1)%get_nrows(),restrv(1)%get_ncols(),&
|
||||
!!$ & desc_acv(i)%get_local_rows(), desc_acv(i)%get_local_cols()
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),max_csize,info
|
||||
csz = sum(nxaggr)
|
||||
call psb_bcast(ictxt,csz)
|
||||
if (csz /= sum(nxaggr)) write(0,*) me,trim(name),' Mismatch matasb',&
|
||||
& csz,sum(nxaggr),max_csize
|
||||
end if
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on entry to tmpwnxt 2'
|
||||
|
||||
|
||||
!
|
||||
! Fix wnxt
|
||||
!
|
||||
if (info == 0) call psb_geall(tmpwnxt,desc_acv(i),info)
|
||||
if (info == 0) call psb_geasb(tmpwnxt,desc_acv(i),info,scratch=.true.)
|
||||
if (info == 0) call psb_halo(tmpw,desc_acv(i-1),info)
|
||||
!!$ write(0,*) trestr%get_nrows(),size(tmpwnxt),trestr%get_ncols(),size(tmpw)
|
||||
|
||||
if (info == 0) call psb_csmm(done,restrv(1),tmpw,dzero,tmpwnxt,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
write(0,*)me,trim(name),'Error from mat_asb/tmpw ',info
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='mat_asb 2')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (i == 1) then
|
||||
nrac = desc_acv(1)%get_local_rows()
|
||||
!!$ write(0,*) 'Copying output w_nxt ',nrac
|
||||
call psb_realloc(nrac,ag%w_nxt,info)
|
||||
ag%w_nxt(1:nrac) = tmpwnxt(1:nrac)
|
||||
!
|
||||
! ILAGGR is fixed later on, but
|
||||
! get a copy in case of an early exit
|
||||
!
|
||||
call psb_safe_ab_cpy(ixaggr,ilaggr,info)
|
||||
end if
|
||||
call psb_safe_ab_cpy(nxaggr,nlaggr,info)
|
||||
call move_alloc(tmpwnxt,tmpw)
|
||||
if (debug) then
|
||||
if (csz /= sum(nlaggr)) write(0,*) me,trim(name),' Mismatch 2 matasb',&
|
||||
& csz,sum(nlaggr),max_csize, info
|
||||
end if
|
||||
call acv(i-1)%free()
|
||||
if ((sum(nlaggr) <= max_csize).or.(any(nlaggr==0))) then
|
||||
!if (me==0) write(0,*) 'Early exit ',any(nlaggr==0),sum(nlaggr),max_csize,i
|
||||
x_sweeps = i
|
||||
exit sweeps_loop
|
||||
end if
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done sweeps_loop iteration:',i,' of ',n_sweeps
|
||||
end if
|
||||
|
||||
end do sweeps_loop
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done sweeps_loop:',x_sweeps
|
||||
end if
|
||||
!!$ write(0,*) me,name,' : End of aggregation sweeps ',&
|
||||
!!$ & n_sweeps,' Final size:',max_csize,desc_acv(n_sweeps)%get_local_rows(),t_prol%get_ncols(),tmp_prol%get_ncols()
|
||||
if (x_sweeps<=0) x_sweeps = n_sweeps
|
||||
|
||||
if (do_timings) call psb_tic(idx_sweeps_mult)
|
||||
!
|
||||
! Ok, now we have all the prolongators, including the last one in global numbering.
|
||||
! Build the product of all prolongators. Need a tmp_desc_ax
|
||||
! which is correct but most of the time overdimensioned
|
||||
!
|
||||
if (.not.allocated(ag%desc_ax)) allocate(ag%desc_ax)
|
||||
!
|
||||
block
|
||||
integer(psb_ipk_) :: i, nnz
|
||||
integer(psb_lpk_) :: ncol, ncsave
|
||||
if (.not.allocated(ag%ac)) allocate(ag%ac)
|
||||
if (.not.allocated(ag%desc_ac)) allocate(ag%desc_ac)
|
||||
call desc_acv(x_sweeps)%clone(ag%desc_ac,info)
|
||||
call desc_acv(x_sweeps)%free(info)
|
||||
call acv(x_sweeps)%move_alloc(ag%ac,info)
|
||||
!!$ call acv(x_sweeps)%clone(ag%ac,info)
|
||||
if (.not.allocated(ag%prol)) allocate(ag%prol)
|
||||
if (.not.allocated(ag%restr)) allocate(ag%restr)
|
||||
|
||||
!call desc_acv(x_sweeps)%clone(ag%desc_ac,info)
|
||||
call psb_cd_reinit(ag%desc_ac,info)
|
||||
ncsave = ag%desc_ac%get_global_rows()
|
||||
!
|
||||
! Note: prolv(i) is already in local numbering
|
||||
! because of the call to mat_asb in the loop above.
|
||||
!
|
||||
call prolv(x_sweeps)%mv_to(csr_prol)
|
||||
!call csr_prol%set_ncols(ag%desc_ac%get_local_cols())
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'Enter prolongator product loop ',x_sweeps
|
||||
end if
|
||||
|
||||
do i=x_sweeps-1, 1, -1
|
||||
call prolv(i)%mv_to(csr_pvi)
|
||||
if (psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 1'
|
||||
!!$ write(0,*) me,' SPMM1 ',csr_pvi%get_nrows(),csr_pvi%get_ncols(),&
|
||||
!!$ & csr_prol%get_nrows(),csr_prol%get_ncols()
|
||||
call psb_par_spspmm(csr_pvi,desc_acv(i),csr_prol,csr_prod_res,ag%desc_ac,info)
|
||||
if ((info /=0).or.psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 2',info
|
||||
call csr_pvi%free()
|
||||
call csr_prod_res%mv_to_fmt(csr_prol,info)
|
||||
if ((info /=0).or.psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 3',info
|
||||
call csr_prol%set_ncols(ag%desc_ac%get_local_cols())
|
||||
if ((info /=0).or.psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 4'
|
||||
end do
|
||||
call csr_prol%mv_to_lfmt(lcsr_prol,info)
|
||||
nnz = lcsr_prol%get_nzeros()
|
||||
call ag%desc_ac%l2gip(lcsr_prol%ja(1:nnz),info)
|
||||
call lcsr_prol%set_ncols(ncsave)
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'Done prolongator product loop ',x_sweeps
|
||||
end if
|
||||
!
|
||||
! Fix ILAGGR here by copying from CSR_PROL%JA
|
||||
!
|
||||
block
|
||||
integer(psb_ipk_) :: nr
|
||||
nr = lcsr_prol%get_nrows()
|
||||
if (nnz /= nr) then
|
||||
write(0,*) me,name,' Issue with prolongator? ',nr,nnz
|
||||
end if
|
||||
call psb_realloc(nr,ilaggr,info)
|
||||
ilaggr(1:nnz) = lcsr_prol%ja(1:nnz)
|
||||
end block
|
||||
call tmp_prol%mv_from(lcsr_prol)
|
||||
call psb_cdasb(ag%desc_ac,info)
|
||||
call ag%ac%set_ncols(ag%desc_ac%get_local_cols())
|
||||
end block
|
||||
|
||||
call tmp_prol%move_alloc(t_prol,info)
|
||||
call t_prol%set_ncols(ag%desc_ac%get_local_cols())
|
||||
call t_prol%set_nrows(desc_acv(0)%get_local_rows())
|
||||
|
||||
nrac = ag%desc_ac%get_local_rows()
|
||||
ncac = ag%desc_ac%get_local_cols()
|
||||
call psb_realloc(nrac,ag%w_nxt,info)
|
||||
ag%w_nxt(1:nrac) = tmpw(1:nrac)
|
||||
|
||||
|
||||
if (do_timings) call psb_toc(idx_sweeps_mult)
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'Out of build loop ',x_sweeps,': Output size:',sum(nlaggr)
|
||||
end if
|
||||
|
||||
|
||||
!call psb_set_debug_level(0)
|
||||
if (dump) then
|
||||
block
|
||||
ivr = desc_acv(x_sweeps)%get_global_indices(owned=.false.)
|
||||
prefix_ = "final_ac"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+9),'(a,i3.3,a)') '_p',me, '.mtx'
|
||||
call acv(x_sweeps)%print(fname,head='Debug aggregates')
|
||||
write(fname(lname+1:lname+13),'(a,i3.3,a)') '_p',me, '-glb.mtx'
|
||||
call acv(x_sweeps)%print(fname,head='Debug aggregates',iv=ivr)
|
||||
prefix_ = "final_tp"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+9),'(a,i3.3,a)') '_p',me, '.mtx'
|
||||
call t_prol%print(fname,head='Tentative prolongator')
|
||||
end block
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_bootCMatch_if')
|
||||
goto 9999
|
||||
end if
|
||||
!!$ write(0,*)me,' ',name,' Getting out with info ',info,&
|
||||
!!$ & allocated(ilaggr),psb_size(ilaggr),allocated(nlaggr),psb_size(nlaggr)
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
contains
|
||||
subroutine do_l1_jacobi(nsweeps,w,a,desc_a)
|
||||
integer(psb_ipk_), intent(in) :: nsweeps
|
||||
real(psb_dpk_), intent(inout) :: w(:)
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
|
||||
end subroutine do_l1_jacobi
|
||||
end subroutine amg_d_parmatch_aggregator_build_tprol
|
||||
@ -0,0 +1,414 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_daggrmat_smth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_daggrmat_smth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is a prolongator from the coarse level to the fine one.
|
||||
!
|
||||
! The prolongator P_C is built according to a smoothed aggregation algorithm,
|
||||
! i.e. it is obtained by applying a damped Jacobi smoother to the piecewise
|
||||
! constant interpolation operator P corresponding to the fine-to-coarse level
|
||||
! mapping built by the amg_aggrmap_bld subroutine:
|
||||
!
|
||||
! P_C = (I - omega*D^(-1)A) * P,
|
||||
!
|
||||
! where D is the diagonal matrix with main diagonal equal to the main diagonal
|
||||
! of A, and omega is a suitable smoothing parameter. An estimate of the spectral
|
||||
! radius of D^(-1)A, to be used in the computation of omega, is provided,
|
||||
! according to the value of p%parms%aggr_omega_alg, specified by the user
|
||||
! through amg_dprecinit and amg_zprecset.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat,
|
||||
! specified by the user through amg_dprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
! aggregator%mat_bld.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_d_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_dml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_dspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_d_inner_mod
|
||||
use amg_d_base_aggregator_mod
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_smth_bld
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
|
||||
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
|
||||
integer(psb_ipk_) :: inaggr
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
character(len=20) :: name
|
||||
type(psb_ld_coo_sparse_mat) :: tmpcoo, ac_coo, lcoo_restr
|
||||
type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
type(psb_d_csr_sparse_mat) :: acsrf, csr_prol, acsr, tcsr
|
||||
real(psb_dpk_), allocatable :: adiag(:)
|
||||
real(psb_dpk_), allocatable :: arwsum(:)
|
||||
logical :: filter_mat
|
||||
integer(psb_ipk_) :: debug_level, debug_unit, err_act
|
||||
integer(psb_ipk_), parameter :: ncmax=16
|
||||
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false., dump_r=.false., dump_p=.false., debug=.false.
|
||||
character(len=80) :: filename
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1, idx_phase3=-1
|
||||
integer(psb_ipk_), save :: idx_cdasb=-1, idx_ptap=-1
|
||||
|
||||
name='amg_parmatch_smth_bld'
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
!debug_level = 2
|
||||
ictxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
theta = parms%aggr_thresh
|
||||
!write(0,*) me,' ',trim(name),' Start ',idx_spspmm
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("PMC_SMTH_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_phase1==-1)) &
|
||||
& idx_phase1 = psb_get_timer_idx("PMC_SMTH_BLD: phase1 ")
|
||||
if ((do_timings).and.(idx_phase2==-1)) &
|
||||
& idx_phase2 = psb_get_timer_idx("PMC_SMTH_BLD: phase2 ")
|
||||
if ((do_timings).and.(idx_phase3==-1)) &
|
||||
& idx_phase3 = psb_get_timer_idx("PMC_SMTH_BLD: phase3 ")
|
||||
if ((do_timings).and.(idx_gtrans==-1)) &
|
||||
& idx_gtrans = psb_get_timer_idx("PMC_SMTH_BLD: gtrans ")
|
||||
if ((do_timings).and.(idx_refine==-1)) &
|
||||
& idx_refine = psb_get_timer_idx("PMC_SMTH_BLD: refine ")
|
||||
if ((do_timings).and.(idx_cdasb==-1)) &
|
||||
& idx_cdasb = psb_get_timer_idx("PMC_SMTH_BLD: cdasb ")
|
||||
if ((do_timings).and.(idx_ptap==-1)) &
|
||||
& idx_ptap = psb_get_timer_idx("PMC_SMTH_BLD: ptap_bld ")
|
||||
|
||||
if (do_timings) call psb_tic(idx_phase1)
|
||||
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
naggrm1 = sum(nlaggr(1:me))
|
||||
naggrp1 = sum(nlaggr(1:me+1))
|
||||
filter_mat = (parms%aggr_filter == amg_filter_mat_)
|
||||
|
||||
!
|
||||
! naggr: number of local aggregates
|
||||
! nrow: local rows.
|
||||
!
|
||||
if (dump_p) then
|
||||
block
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
integer(psb_lpk_) :: i
|
||||
character(len=132) :: aname
|
||||
type(psb_ldspmat_type) :: aglob
|
||||
type(psb_dspmat_type) :: atmp
|
||||
!!$ call a%cp_to(acsr)
|
||||
!!$ call atmp%cp_from(acsr)
|
||||
write(0,*) me,' ',trim(name),' Dumping inp_prol/restr'
|
||||
write(aname,'(a,i0,a,i0,a)') 'tprol-',desc_a%get_global_rows(),'-p',me,'.mtx'
|
||||
call t_prol%print(fname=aname,head='Test ')
|
||||
end block
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_refine)
|
||||
! Get the diagonal D
|
||||
adiag = a%get_diag(info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_realloc(ncol,adiag,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_halo(adiag,desc_a,info)
|
||||
if (info == psb_success_) call a%cp_to(acsr)
|
||||
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Initial copies done.'
|
||||
|
||||
call acsr%cp_to_fmt(acsrf,info)
|
||||
|
||||
if (filter_mat) then
|
||||
!
|
||||
! Build the filtered matrix Af from A
|
||||
!
|
||||
|
||||
do i=1, nrow
|
||||
tmp = dzero
|
||||
jd = -1
|
||||
do j=acsrf%irp(i),acsrf%irp(i+1)-1
|
||||
if (acsrf%ja(j) == i) jd = j
|
||||
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
|
||||
tmp=tmp+acsrf%val(j)
|
||||
acsrf%val(j)=dzero
|
||||
endif
|
||||
|
||||
enddo
|
||||
if (jd == -1) then
|
||||
write(0,*) 'Wrong input: we need the diagonal!!!!', i
|
||||
else
|
||||
acsrf%val(jd)=acsrf%val(jd)-tmp
|
||||
end if
|
||||
enddo
|
||||
! Take out zeroed terms
|
||||
call acsrf%clean_zeros(info)
|
||||
end if
|
||||
|
||||
|
||||
do i=1,size(adiag)
|
||||
if (adiag(i) /= dzero) then
|
||||
adiag(i) = done / adiag(i)
|
||||
else
|
||||
adiag(i) = done
|
||||
end if
|
||||
end do
|
||||
if (do_timings) call psb_toc(idx_refine)
|
||||
|
||||
if (parms%aggr_omega_alg == amg_eig_est_) then
|
||||
|
||||
if (parms%aggr_eig == amg_max_norm_) then
|
||||
allocate(arwsum(nrow))
|
||||
call acsr%arwsum(arwsum)
|
||||
anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
|
||||
call psb_amx(ictxt,anorm)
|
||||
omega = 4.d0/(3.d0*anorm)
|
||||
parms%aggr_omega_val = omega
|
||||
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_eig_')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (parms%aggr_omega_alg == amg_user_choice_) then
|
||||
|
||||
omega = parms%aggr_omega_val
|
||||
|
||||
else if (parms%aggr_omega_alg /= amg_user_choice_) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
call acsrf%scal(adiag,info)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Filtering and scaling done.',info
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
inaggr = naggr
|
||||
|
||||
call t_prol%cp_to(tmpcoo)
|
||||
|
||||
call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzl),info)
|
||||
call tmpcoo%set_ncols(desc_ac%get_local_cols())
|
||||
call tmpcoo%mv_to_ifmt(tcsr,info)
|
||||
!
|
||||
! Build the smoothed prolongator using either A or Af
|
||||
! csr_prol = (I-w*D*A) Prol csr_prol = (I-w*D*Af) Prol
|
||||
! This is always done through the variable acsrf which
|
||||
! is a bit less readable, but saves space and one extra matrix copy
|
||||
!
|
||||
call omega_smooth(omega,acsrf)
|
||||
if (do_timings) call psb_toc(idx_phase1)
|
||||
|
||||
if (do_timings) call psb_tic(idx_spspmm)
|
||||
call psb_par_spspmm(acsrf,desc_a,tcsr,csr_prol,desc_ac,info)
|
||||
call tcsr%free()
|
||||
if (do_timings) call psb_toc(idx_spspmm)
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Now that we have the smoothed prolongator, we can
|
||||
! compute the triple product.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_cdasb)
|
||||
call psb_cdasb(desc_ac,info)
|
||||
if (do_timings) call psb_toc(idx_cdasb)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
|
||||
call csr_prol%mv_to_coo(coo_prol,info)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done SPSPMM 1'
|
||||
|
||||
if (do_timings) call psb_tic(idx_ptap)
|
||||
if (.not.allocated(ag%desc_ax)) allocate(ag%desc_ax)
|
||||
call amg_ptap_bld(acsr,desc_a,nlaggr,parms,ac,&
|
||||
& coo_prol,desc_ac,coo_restr,info,desc_ax=ag%desc_ax)
|
||||
if (do_timings) call psb_toc(idx_ptap)
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus()
|
||||
if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
|
||||
! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
|
||||
|
||||
if (dump_r) then
|
||||
block
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
integer(psb_lpk_) :: i
|
||||
character(len=132) :: aname
|
||||
type(psb_ldspmat_type) :: aglob
|
||||
type(psb_dspmat_type) :: atmp
|
||||
write(0,*) me,' ',trim(name),' Dumping prol/restr'
|
||||
ivc = [(i,i=1,desc_a%get_local_cols())]
|
||||
call desc_a%l2gip(ivc,info)
|
||||
ivr = [(i,i=1,desc_ac%get_local_cols())]
|
||||
call desc_ac%l2gip(ivr,info)
|
||||
|
||||
write(aname,'(a,i0,a,i0,a)') 'restr-',desc_ac%get_global_rows(),'-p',me,'.mtx'
|
||||
|
||||
call op_restr%print(fname=aname,head='Test ',ivc=ivc)
|
||||
!!$ write(aname,'(a,i0,a,i0,a)') 'prol-',desc_ac%get_global_rows(),'-p',me,'.mtx'
|
||||
!!$ call op_prol%print(fname=aname,head='Test ')
|
||||
!!$ call psb_gather(aglob,atmp,desc_a,info)
|
||||
!!$ if (me==psb_root_) then
|
||||
!!$ write(aname,'(a,i0,a)') 'a-inp-g-',aglob%get_nrows(),'.mtx'
|
||||
!!$ call aglob%print(fname=aname,head='Test ')
|
||||
!!$ end if
|
||||
|
||||
end block
|
||||
end if
|
||||
if (do_timings) call psb_toc(idx_phase2)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine omega_smooth(omega,acsr)
|
||||
implicit none
|
||||
real(psb_dpk_),intent(in) :: omega
|
||||
type(psb_d_csr_sparse_mat), intent(inout) :: acsr
|
||||
!
|
||||
integer(psb_ipk_) :: i,j
|
||||
do i=1,acsr%get_nrows()
|
||||
do j=acsr%irp(i),acsr%irp(i+1)-1
|
||||
if (acsr%ja(j) == i) then
|
||||
acsr%val(j) = done - omega*acsr%val(j)
|
||||
else
|
||||
acsr%val(j) = - omega*acsr%val(j)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
end subroutine omega_smooth
|
||||
|
||||
end subroutine amg_d_parmatch_smth_bld
|
||||
@ -0,0 +1,194 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_daggrmat_nosmth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_daggrmat_nosmth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is the piecewise constant interpolation operator corresponding
|
||||
! the fine-to-coarse level mapping built by amg_aggrmap_bld.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat
|
||||
! specified by the user through amg_dprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
!
|
||||
! For details see
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
|
||||
! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math.,
|
||||
! 57 (2007), 1181-1196.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_d_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_dml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_dspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_d_inner_mod
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_spmm_bld
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(inout) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np,me
|
||||
character(len=20) :: name
|
||||
type(psb_d_csr_sparse_mat) :: acsr
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
|
||||
& naggr, nzt, naggrm1, naggrp1, i, k
|
||||
integer(psb_ipk_) :: inaggr, nzlp
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='amg_parmatch_spmm_bld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
call a%cp_to(acsr)
|
||||
|
||||
call amg_d_parmatch_spmm_bld_inner(acsr,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err="SPMM_BLD_INNER")
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done spmm_bld '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_d_parmatch_spmm_bld
|
||||
@ -0,0 +1,210 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_daggrmat_nosmth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_daggrmat_nosmth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is the piecewise constant interpolation operator corresponding
|
||||
! the fine-to-coarse level mapping built by amg_aggrmap_bld.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat
|
||||
! specified by the user through amg_dprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
!
|
||||
! For details see
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
|
||||
! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math.,
|
||||
! 57 (2007), 1181-1196.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_d_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_dml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_dspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_d_inner_mod
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_spmm_bld_inner
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
type(psb_d_csr_sparse_mat), intent(inout) :: a_csr
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(out) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me, ndx
|
||||
character(len=40) :: name
|
||||
type(psb_ld_coo_sparse_mat) :: tmpcoo
|
||||
type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
type(psb_d_csr_sparse_mat) :: ac_csr, csr_restr
|
||||
type(psb_desc_type), target :: tmp_desc
|
||||
type(psb_ldspmat_type) :: lac
|
||||
integer(psb_ipk_) :: debug_level, debug_unit, naggr
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
|
||||
& nzt, naggrm1, naggrp1, i, k
|
||||
integer(psb_lpk_), allocatable :: ia(:),ja(:)
|
||||
!integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza, nrpsave, ncpsave, nzpsave
|
||||
logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_prolcnv=-1, idx_proltrans=-1, idx_asb=-1
|
||||
|
||||
name='amg_parmatch_spmm_bld_inner'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("SPMM_BLD: spspmm ")
|
||||
if ((do_timings).and.(idx_prolcnv==-1)) &
|
||||
& idx_prolcnv = psb_get_timer_idx("SPMM_BLD: prolcnv ")
|
||||
if ((do_timings).and.(idx_proltrans==-1)) &
|
||||
& idx_proltrans = psb_get_timer_idx("SPMM_BLD: proltrans")
|
||||
if ((do_timings).and.(idx_asb==-1)) &
|
||||
& idx_asb = psb_get_timer_idx("SPMM_BLD: asb ")
|
||||
|
||||
if (do_timings) call psb_tic(idx_prolcnv)
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
naggrm1 = sum(nlaggr(1:me))
|
||||
naggrp1 = sum(nlaggr(1:me+1))
|
||||
|
||||
!
|
||||
! Here T_PROL should be arriving with GLOBAL indices on the cols
|
||||
! and LOCAL indices on the rows.
|
||||
!
|
||||
if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',&
|
||||
& op_prol%get_fmt(),op_prol%get_nrows(),op_prol%get_ncols(),op_prol%get_nzeros(),&
|
||||
& nrow,ntaggr,naggr
|
||||
|
||||
call t_prol%cp_to(tmpcoo)
|
||||
|
||||
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
if (debug) write(0,*) me,' ',trim(name),' coo_prol: ',&
|
||||
& tmpcoo%ia(1:min(10,nzl)),' :',tmpcoo%ja(1:min(10,nzl))
|
||||
call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzl),info)
|
||||
call tmpcoo%set_ncols(desc_ac%get_local_cols())
|
||||
call tmpcoo%cp_to_icoo(coo_prol,info)
|
||||
|
||||
call amg_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
& coo_prol,desc_ac,coo_restr,info)
|
||||
|
||||
nzl = coo_prol%get_nzeros()
|
||||
if (debug) write(0,*) me,' ',trim(name),' coo_prol: ',&
|
||||
& coo_prol%ia(1:min(10,nzl)),' :',coo_prol%ja(1:min(10,nzl))
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
if (debug) then
|
||||
write(0,*) me,' ',trim(name),' Checkpoint at exit'
|
||||
call psb_barrier(ictxt)
|
||||
write(0,*) me,' ',trim(name),' Checkpoint through'
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x a3')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_d_parmatch_spmm_bld_inner
|
||||
@ -0,0 +1,180 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_daggrmat_nosmth_bld_ov.F90
|
||||
!
|
||||
! Subroutine: amg_daggrmat_nosmth_bld_ov
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is the piecewise constant interpolation operator corresponding
|
||||
! the fine-to-coarse level mapping built by amg_aggrmap_bld_ov.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat
|
||||
! specified by the user through amg_dprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
!
|
||||
! For details see
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
|
||||
! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math.,
|
||||
! 57 (2007), 1181-1196.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_d_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_dml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_dspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_d_inner_mod
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_spmm_bld_ov
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
type(psb_dspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_dspmat_type), intent(inout) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
character(len=20) :: name
|
||||
type(psb_d_csr_sparse_mat) :: acsr
|
||||
type(psb_ld_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
|
||||
& naggr, nzt, naggrm1, naggrp1, i, k
|
||||
integer(psb_ipk_) :: inaggr, nzlp
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical, parameter :: debug=.false., new_version=.true.
|
||||
|
||||
name='amg_parmatch_spmm_bld_ov'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
call a%mv_to(acsr)
|
||||
|
||||
call amg_d_parmatch_spmm_bld_inner(acsr,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on exit from bld_inner',info
|
||||
|
||||
!!$ else
|
||||
!!$ naggr = nlaggr(me+1)
|
||||
!!$ ntaggr = sum(nlaggr)
|
||||
!!$ naggrm1 = sum(nlaggr(1:me))
|
||||
!!$ naggrp1 = sum(nlaggr(1:me+1))
|
||||
!!$ call op_prol%mv_to(coo_prol)
|
||||
!!$ inaggr = naggr
|
||||
!!$ call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
|
||||
!!$ nzlp = coo_prol%get_nzeros()
|
||||
!!$ call desc_ac%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info)
|
||||
!!$ call coo_prol%set_ncols(desc_ac%get_local_cols())
|
||||
!!$ call amg_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
|
||||
!!$ & coo_prol,desc_ac,coo_restr,info)
|
||||
!!$ call psb_cdasb(desc_ac,info)
|
||||
!!$ !call desc_ac%free(info)
|
||||
!!$ !write(0,*) me, 'Size of nlaggr',size(nlaggr),nlaggr(1)
|
||||
!!$ call op_prol%mv_from(coo_prol)
|
||||
!!$ call op_restr%mv_from(coo_restr)
|
||||
!!$
|
||||
!!$ end if
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err="SPMM_BLD_INNER")
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done spmm_bld '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_d_parmatch_spmm_bld_ov
|
||||
@ -0,0 +1,251 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_d_parmatch_unsmth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_d_parmatch_unsmth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is a prolongator from the coarse level to the fine one.
|
||||
!
|
||||
! The prolongator P_C is built according to a smoothed aggregation algorithm,
|
||||
! i.e. it is obtained by applying a damped Jacobi smoother to the piecewise
|
||||
! constant interpolation operator P corresponding to the fine-to-coarse level
|
||||
! mapping built by the amg_aggrmap_bld subroutine:
|
||||
!
|
||||
! P_C = (I - omega*D^(-1)A) * P,
|
||||
!
|
||||
! where D is the diagonal matrix with main diagonal equal to the main diagonal
|
||||
! of A, and omega is a suitable smoothing parameter. An estimate of the spectral
|
||||
! radius of D^(-1)A, to be used in the computation of omega, is provided,
|
||||
! according to the value of p%parms%aggr_omega_alg, specified by the user
|
||||
! through amg_dprecinit and amg_zprecset.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat,
|
||||
! specified by the user through amg_dprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
! aggregator%mat_bld.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_dspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_d_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_dml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_dspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_dspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_dspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_d_inner_mod
|
||||
use amg_d_base_aggregator_mod
|
||||
use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_unsmth_bld
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_dml_parms), intent(inout) :: parms
|
||||
type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
|
||||
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
|
||||
integer(psb_ipk_) :: inaggr
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
character(len=20) :: name
|
||||
type(psb_ld_coo_sparse_mat) :: lcoo_prol
|
||||
type(psb_d_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
type(psb_d_csr_sparse_mat) :: acsr
|
||||
type(psb_d_csr_sparse_mat) :: csr_prol, acsr3, csr_restr, ac_csr
|
||||
real(psb_dpk_), allocatable :: adiag(:)
|
||||
real(psb_dpk_), allocatable :: arwsum(:)
|
||||
logical :: filter_mat
|
||||
integer(psb_ipk_) :: debug_level, debug_unit, err_act
|
||||
integer(psb_ipk_), parameter :: ncmax=16
|
||||
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false., dump_r=.false., dump_p=.false., debug=.false.
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1
|
||||
character(len=80) :: filename
|
||||
|
||||
name='amg_parmatch_unsmth_bld'
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
theta = parms%aggr_thresh
|
||||
!write(0,*) me,' ',trim(name),' Start '
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("PMC_UNSMTH_BLD: par_spspmm")
|
||||
|
||||
!
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
naggrm1 = sum(nlaggr(1:me))
|
||||
naggrp1 = sum(nlaggr(1:me+1))
|
||||
!write(0,*) me,' ',trim(name),' input sizes',nlaggr(:),':',naggr
|
||||
|
||||
call a%cp_to(acsr)
|
||||
call t_prol%mv_to(lcoo_prol)
|
||||
|
||||
inaggr = naggr
|
||||
call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
|
||||
nzl = lcoo_prol%get_nzeros()
|
||||
call desc_ac%indxmap%g2lip_ins(lcoo_prol%ja(1:nzl),info)
|
||||
call lcoo_prol%set_ncols(desc_ac%get_local_cols())
|
||||
call lcoo_prol%cp_to_icoo(coo_prol,info)
|
||||
|
||||
if (debug) call check_coo(me,trim(name)//' Check 1 on coo_prol:',coo_prol)
|
||||
|
||||
call psb_cdasb(desc_ac,info)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
if (.not.allocated(ag%desc_ax)) allocate(ag%desc_ax)
|
||||
|
||||
call amg_ptap_bld(acsr,desc_a,nlaggr,parms,ac,&
|
||||
& coo_prol,desc_ac,coo_restr,info,desc_ax=ag%desc_ax)
|
||||
|
||||
call op_restr%cp_from(coo_restr)
|
||||
call op_prol%mv_from(coo_prol)
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus()
|
||||
if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
|
||||
! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
|
||||
|
||||
if (debug) then
|
||||
write(0,*) me,' ',trim(name),' Checkpoint at exit'
|
||||
call psb_barrier(ictxt)
|
||||
write(0,*) me,' ',trim(name),' Checkpoint through'
|
||||
block
|
||||
character(len=128) :: fname, prefix_
|
||||
integer :: lname
|
||||
prefix_ = "unsmth_bld_"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+10),'(a,i3.3,a)') '_p_',me, '.mtx'
|
||||
call op_prol%print(fname,head='Debug aggregates')
|
||||
write(fname(lname+1:lname+10),'(a,i3.3,a)') '_r_',me, '.mtx'
|
||||
call op_restr%print(fname,head='Debug aggregates')
|
||||
write(fname(lname+1:lname+11),'(a,i3.3,a)') '_ac_',me, '.mtx'
|
||||
call ac%print(fname,head='Debug aggregates')
|
||||
end block
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
subroutine check_coo(me,string,coo)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: me
|
||||
type(psb_d_coo_sparse_mat) :: coo
|
||||
character(len=*) :: string
|
||||
integer(psb_lpk_) :: nr,nc,nz
|
||||
nr = coo%get_nrows()
|
||||
nc = coo%get_ncols()
|
||||
nz = coo%get_nzeros()
|
||||
write(0,*) me,string,nr,nc,&
|
||||
& minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
|
||||
& minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
|
||||
end subroutine check_coo
|
||||
|
||||
end subroutine amg_d_parmatch_unsmth_bld
|
||||
@ -0,0 +1,231 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_s_parmatch_aggregator_mat_asb.f90
|
||||
!
|
||||
! Subroutine: amg_s_parmatch_aggregator_mat_asb
|
||||
! Version: real
|
||||
!
|
||||
!
|
||||
! From a given AC to final format, generating DESC_AC.
|
||||
! This is quite involved, because in the context of aggregation based
|
||||
! on parallel matching we are building the matrix hierarchy within BLD_TPROL
|
||||
! as we go, especially if we have multiple sweeps, hence this code is called
|
||||
! in two completely different contexts:
|
||||
! 1. Within bld_tprol for the internal hierarchy
|
||||
! 2. Outside, from amg_hierarchy_bld
|
||||
! The solution we have found is for bld_tprol to copy its output
|
||||
! into special components ag%ac ag%desc_ac etc so that:
|
||||
! 1. if they are allocated, it means that bld_tprol has been already invoked, we are in
|
||||
! amg_hierarchy_bld and we only need to copy them
|
||||
! 2. If they are not allocated, we are within bld_tprol, and we need to actually
|
||||
! perform the various needed steps.
|
||||
!
|
||||
! Arguments:
|
||||
! ag - type(amg_s_parmatch_aggregator_type), input/output.
|
||||
! The aggregator object
|
||||
! parms - type(amg_sml_parms), input
|
||||
! The aggregation parameters
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! ac - type(psb_sspmat_type), inout
|
||||
! The coarse matrix
|
||||
! desc_ac - type(psb_desc_type), output.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
!
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), input/output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_s_parmatch_aggregator_inner_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_aggregator_inner_mat_asb
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
type(psb_sspmat_type), intent(inout) :: op_prol,op_restr
|
||||
type(psb_sspmat_type), intent(inout) :: ac
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
type(psb_ls_coo_sparse_mat) :: acoo, bcoo
|
||||
type(psb_ls_csr_sparse_mat) :: acsr1
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: err_act, debug_level, debug_unit
|
||||
character(len=20) :: name='d_parmatch_inner_mat_asb'
|
||||
character(len=80) :: aname
|
||||
logical, parameter :: debug=.false., dump_prol_restr=.false.
|
||||
|
||||
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' Start:',&
|
||||
& allocated(ag%ac),allocated(ag%desc_ac), allocated(ag%prol),allocated(ag%restr)
|
||||
|
||||
|
||||
select case(parms%coarse_mat)
|
||||
|
||||
case(amg_distr_mat_)
|
||||
! Do nothing, it has already been done in spmm_bld_ov.
|
||||
|
||||
case(amg_repl_mat_)
|
||||
!
|
||||
!
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='no repl coarse_mat_ here')
|
||||
goto 9999
|
||||
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
|
||||
end subroutine amg_s_parmatch_aggregator_inner_mat_asb
|
||||
@ -0,0 +1,277 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_s_base_aggregator_mat_bld.f90
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_s_parmatch_aggregator_mat_asb.f90
|
||||
!
|
||||
! Subroutine: amg_s_parmatch_aggregator_mat_asb
|
||||
! Version: real
|
||||
!
|
||||
!
|
||||
! From a given AC to final format, generating DESC_AC.
|
||||
! This is quite involved, because in the context of aggregation based
|
||||
! on parallel matching we are building the matrix hierarchy within BLD_TPROL
|
||||
! as we go, especially if we have multiple sweeps, hence this code is called
|
||||
! in two completely different contexts:
|
||||
! 1. Within bld_tprol for the internal hierarchy
|
||||
! 2. Outside, from amg_hierarchy_bld
|
||||
! The solution we have found is for bld_tprol to copy its output
|
||||
! into special components ag%ac ag%desc_ac etc so that:
|
||||
! 1. if they are allocated, it means that bld_tprol has been already invoked, we are in
|
||||
! amg_hierarchy_bld and we only need to copy them
|
||||
! 2. If they are not allocated, we are within bld_tprol, and we need to actually
|
||||
! perform the various needed steps.
|
||||
!
|
||||
! Arguments:
|
||||
! ag - type(amg_s_parmatch_aggregator_type), input/output.
|
||||
! The aggregator object
|
||||
! parms - type(amg_sml_parms), input
|
||||
! The aggregation parameters
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! ac - type(psb_sspmat_type), inout
|
||||
! The coarse matrix
|
||||
! desc_ac - type(psb_desc_type), output.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
!
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), input/output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_s_parmatch_aggregator_mat_asb(ag,parms,a,desc_a,&
|
||||
& ac,desc_ac, op_prol,op_restr,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_aggregator_mat_asb
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
type(psb_sspmat_type), intent(inout) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
type(psb_ls_coo_sparse_mat) :: tmpcoo
|
||||
type(psb_lsspmat_type) :: tmp_ac
|
||||
integer(psb_ipk_) :: i_nr, i_nc, i_nl, nzl
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: err_act, debug_level, debug_unit
|
||||
character(len=20) :: name='d_parmatch_mat_asb'
|
||||
character(len=80) :: aname
|
||||
logical, parameter :: debug=.false., dump_prol_restr=.false., dump_ac=.false.
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
if (psb_get_errstatus().ne.0) then
|
||||
write(0,*) me,' From:',trim(name),':',psb_get_errstatus()
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' Start:',&
|
||||
& allocated(ag%ac),allocated(ag%desc_ac), allocated(ag%prol),allocated(ag%restr)
|
||||
|
||||
select case(parms%coarse_mat)
|
||||
|
||||
case(amg_distr_mat_)
|
||||
|
||||
call ac%cscnv(info,type='csr')
|
||||
call op_prol%cscnv(info,type='csr')
|
||||
call op_restr%cscnv(info,type='csr')
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done ac '
|
||||
|
||||
case(amg_repl_mat_)
|
||||
!
|
||||
! We are assuming here that an d matrix
|
||||
! can hold all entries
|
||||
!
|
||||
if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then
|
||||
ntaggr = desc_ac%get_global_rows()
|
||||
i_nr = ntaggr
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call op_prol%mv_to(tmpcoo)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I')
|
||||
call op_prol%mv_from(tmpcoo)
|
||||
|
||||
call op_restr%mv_to(tmpcoo)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I')
|
||||
call op_restr%mv_from(tmpcoo)
|
||||
|
||||
call op_prol%set_ncols(i_nr)
|
||||
call op_restr%set_nrows(i_nr)
|
||||
|
||||
call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,&
|
||||
& dupl=psb_dupl_add_,keeploc=.false.)
|
||||
call tmp_ac%mv_to(tmpcoo)
|
||||
call ac%mv_from(tmpcoo)
|
||||
|
||||
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
|
||||
if (info == psb_success_) call psb_cdasb(desc_ac,info)
|
||||
!
|
||||
! Now that we have the descriptors and the restrictor, we should
|
||||
! update the W. But we don't, because REPL is only valid
|
||||
! at the coarsest level, so no need to carry over.
|
||||
!
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_coarse_mat_')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
|
||||
end subroutine amg_s_parmatch_aggregator_mat_asb
|
||||
@ -0,0 +1,275 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_s_base_aggregator_mat_bld.f90
|
||||
!
|
||||
! Subroutine: amg_s_base_aggregator_mat_bld
|
||||
! Version: s
|
||||
!
|
||||
! This routine builds the matrix associated to the current level of the
|
||||
! multilevel preconditioner from the matrix associated to the previous level,
|
||||
! by using the user-specified aggregation technique (therefore, it also builds the
|
||||
! prolongation and restriction operators mapping the current level to the
|
||||
! previous one and vice versa).
|
||||
! The current level is regarded as the coarse one, while the previous as
|
||||
! the fine one. This is in agreement with the fact that the routine is called,
|
||||
! by amg_mlprec_bld, only on levels >=2.
|
||||
! The coarse-level matrix A_C is built from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is a prolongator from the coarse level to the fine one.
|
||||
!
|
||||
! A mapping from the nodes of the adjacency graph of A to the nodes of the
|
||||
! adjacency graph of A_C has been computed by the amg_aggrmap_bld subroutine.
|
||||
! The prolongator P_C is built here from this mapping, according to the
|
||||
! value of p%iprcparm(amg_aggr_kind_), specified by the user through
|
||||
! amg_sprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
! amg_s_lev_aggrmat_bld.
|
||||
!
|
||||
! Currently four different prolongators are implemented, corresponding to
|
||||
! four aggregation algorithms:
|
||||
! 1. un-smoothed aggregation,
|
||||
! 2. smoothed aggregation,
|
||||
! 3. "bizarre" aggregation.
|
||||
! 4. minimum energy
|
||||
! 1. The non-smoothed aggregation uses as prolongator the piecewise constant
|
||||
! interpolation operator corresponding to the fine-to-coarse level mapping built
|
||||
! by p%aggr%bld_tprol. This is called tentative prolongator.
|
||||
! 2. The smoothed aggregation uses as prolongator the operator obtained by applying
|
||||
! a damped Jacobi smoother to the tentative prolongator.
|
||||
! 3. The "bizarre" aggregation uses a prolongator proposed by the authors of AMG4PSBLAS.
|
||||
! This prolongator still requires a deep analysis and testing and its use is
|
||||
! not recommended.
|
||||
! 4. Minimum energy aggregation
|
||||
!
|
||||
! For more details see
|
||||
! M. Brezina and P. Vanek, A black-box iterative solver based on a two-level
|
||||
! Schwarz method, Computing, 63 (1999), 233-263.
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of PSBLAS-based
|
||||
! parallel two-level Schwarz preconditioners, Appl. Num. Math., 57 (2007),
|
||||
! 1181-1196.
|
||||
! M. Sala, R. Tuminaro: A new Petrov-Galerkin smoothed aggregation preconditioner
|
||||
! for nonsymmetric linear systems, SIAM J. Sci. Comput., 31(1):143-166 (2008)
|
||||
!
|
||||
!
|
||||
! The main structure is:
|
||||
! 1. Perform sanity checks;
|
||||
! 2. Compute prolongator/restrictor/AC
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! ag - type(amg_s_base_aggregator_type), input/output.
|
||||
! The aggregator object
|
||||
! parms - type(amg_sml_parms), input
|
||||
! The aggregation parameters
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! ac - type(psb_sspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_s_parmatch_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_s_inner_mod
|
||||
use amg_s_prec_type
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_aggregator_mat_bld
|
||||
implicit none
|
||||
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
character(len=20) :: name
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
type(psb_sspmat_type) :: atmp
|
||||
|
||||
name='d_parmatch_mat_bld'
|
||||
if (psb_get_errstatus().ne.0) return
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by
|
||||
!
|
||||
|
||||
call clean_shortcuts(ag)
|
||||
!
|
||||
! When requesting smoothed aggregation we cannot use the
|
||||
! unsmoothed shortcuts
|
||||
!
|
||||
select case (parms%aggr_prol)
|
||||
case (amg_no_smooth_)
|
||||
call amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
|
||||
case(amg_smooth_prol_)
|
||||
call amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
|
||||
!!$ case(amg_biz_prol_)
|
||||
!!$ call amg_saggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
|
||||
!!$ & parms,ac,desc_ac,op_prol,op_restr,info)
|
||||
|
||||
case(amg_min_energy_)
|
||||
call amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
|
||||
& parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Invalid aggr kind')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
subroutine clean_shortcuts(ag)
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
|
||||
integer(psb_ipk_) :: info
|
||||
if (allocated(ag%prol)) then
|
||||
call ag%prol%free()
|
||||
deallocate(ag%prol)
|
||||
end if
|
||||
if (allocated(ag%restr)) then
|
||||
call ag%restr%free()
|
||||
deallocate(ag%restr)
|
||||
end if
|
||||
if (ag%unsmoothed_hierarchy) then
|
||||
if (allocated(ag%ac)) call move_alloc(ag%ac, ag%rwa)
|
||||
if (allocated(ag%desc_ac)) call move_alloc(ag%desc_ac,ag%rwdesc)
|
||||
else
|
||||
if (allocated(ag%ac)) then
|
||||
call ag%ac%free()
|
||||
deallocate(ag%ac)
|
||||
end if
|
||||
if (allocated(ag%desc_ac)) then
|
||||
call ag%desc_ac%free(info)
|
||||
deallocate(ag%desc_ac)
|
||||
end if
|
||||
end if
|
||||
end subroutine clean_shortcuts
|
||||
|
||||
end subroutine amg_s_parmatch_aggregator_mat_bld
|
||||
@ -0,0 +1,565 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! File: amg_s_parmatch_aggregator_tprol.f90
|
||||
!
|
||||
! Subroutine: amg_s_parmatch_aggregator_tprol
|
||||
! Version: real
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
& a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_s_prec_type
|
||||
use amg_s_inner_mod
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_aggregator_build_tprol
|
||||
use iso_c_binding
|
||||
implicit none
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(amg_saggr_data), intent(in) :: ag_data
|
||||
type(psb_sspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
|
||||
type(psb_lsspmat_type), intent(out) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
|
||||
! Local variables
|
||||
real(psb_spk_), allocatable :: tmpw(:), tmpwnxt(:)
|
||||
integer(psb_lpk_), allocatable :: ixaggr(:), nxaggr(:), tlaggr(:), ivr(:)
|
||||
type(psb_sspmat_type) :: a_tmp
|
||||
integer(c_int) :: match_algorithm, n_sweeps, max_csize, max_nlevels
|
||||
character(len=40) :: name, ch_err
|
||||
character(len=80) :: fname, prefix_
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act, ierr
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_) :: i, j, k, nr, nc
|
||||
integer(psb_lpk_) :: isz, num_pcols, nrac, ncac, lname, nz, x_sweeps, csz
|
||||
integer(psb_lpk_) :: psz, sizes(4)
|
||||
type(psb_s_csr_sparse_mat), target :: csr_prol, csr_pvi, csr_prod_res, acsr
|
||||
type(psb_ls_csr_sparse_mat), target :: lcsr_prol
|
||||
type(psb_desc_type), allocatable :: desc_acv(:)
|
||||
type(psb_ls_coo_sparse_mat) :: tmpcoo, transp_coo
|
||||
type(psb_sspmat_type), allocatable :: acv(:)
|
||||
type(psb_sspmat_type), allocatable :: prolv(:), restrv(:)
|
||||
type(psb_lsspmat_type) :: tmp_prol, tmp_pg, tmp_restr
|
||||
type(psb_desc_type) :: tmp_desc_ac, tmp_desc_ax, tmp_desc_p
|
||||
integer(psb_ipk_), save :: idx_mboxp=-1, idx_spmmbld=-1, idx_sweeps_mult=-1
|
||||
logical, parameter :: dump=.false., do_timings=.true., debug=.false., &
|
||||
& dump_prol_restr=.false.
|
||||
|
||||
name='s_parmatch_tprol'
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
if (psb_get_errstatus().ne.0) then
|
||||
write(0,*) me,trim(name),' Err_status :',psb_get_errstatus()
|
||||
return
|
||||
end if
|
||||
if (debug) write(0,*) me,trim(name),' Start '
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
|
||||
if ((do_timings).and.(idx_mboxp==-1)) &
|
||||
& idx_mboxp = psb_get_timer_idx("PMC_TPROL: MatchBoxP")
|
||||
if ((do_timings).and.(idx_spmmbld==-1)) &
|
||||
& idx_spmmbld = psb_get_timer_idx("PMC_TPROL: spmm_bld")
|
||||
if ((do_timings).and.(idx_sweeps_mult==-1)) &
|
||||
& idx_sweeps_mult = psb_get_timer_idx("PMC_TPROL: sweeps_mult")
|
||||
|
||||
|
||||
call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
|
||||
& amg_mult_ml_,is_legal_ml_cycle)
|
||||
call amg_check_def(parms%par_aggr_alg,'Aggregation',&
|
||||
& amg_dec_aggr_,is_legal_ml_par_aggr_alg)
|
||||
call amg_check_def(parms%aggr_ord,'Ordering',&
|
||||
& amg_aggr_ord_nat_,is_legal_ml_aggr_ord)
|
||||
call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
|
||||
match_algorithm = ag%matching_alg
|
||||
n_sweeps = ag%n_sweeps
|
||||
if (2**n_sweeps /= ag%orig_aggr_size) then
|
||||
if (me == 0) then
|
||||
write(debug_unit, *) 'Warning: AGGR_SIZE reset to value ',2**n_sweeps
|
||||
end if
|
||||
end if
|
||||
if (ag%max_csize > 0) then
|
||||
max_csize = ag%max_csize
|
||||
else
|
||||
max_csize = ag_data%min_coarse_size
|
||||
end if
|
||||
if (ag%max_nlevels > 0) then
|
||||
max_nlevels = ag%max_nlevels
|
||||
else
|
||||
max_nlevels = ag_data%max_levs
|
||||
end if
|
||||
if (.true.) then
|
||||
block
|
||||
integer(psb_ipk_) :: ipv(2)
|
||||
ipv(1) = max_csize
|
||||
ipv(2) = n_sweeps
|
||||
call psb_bcast(ictxt,ipv)
|
||||
max_csize = ipv(1)
|
||||
n_sweeps = ipv(2)
|
||||
end block
|
||||
else
|
||||
call psb_bcast(ictxt,max_csize)
|
||||
call psb_bcast(ictxt,n_sweeps)
|
||||
end if
|
||||
if (n_sweeps /= ag%n_sweeps) then
|
||||
write(0,*) me,' Inconsistent N_SWEEPS ',n_sweeps,ag%n_sweeps
|
||||
end if
|
||||
!!$ if (me==0) write(0,*) 'Matching sweeps: ',n_sweeps
|
||||
n_sweeps = max(1,n_sweeps)
|
||||
if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,max_csize
|
||||
if (ag%unsmoothed_hierarchy.and.allocated(ag%base_a)) then
|
||||
call ag%base_a%cp_to(acsr)
|
||||
if (ag%do_clean_zeros) call acsr%clean_zeros(info)
|
||||
nr = acsr%get_nrows()
|
||||
if (psb_size(ag%w) < nr) call ag%bld_default_w(nr)
|
||||
isz = acsr%get_ncols()
|
||||
|
||||
call psb_realloc(isz,ixaggr,info)
|
||||
if (info == psb_success_) &
|
||||
& allocate(acv(0:n_sweeps), desc_acv(0:n_sweeps),&
|
||||
& prolv(n_sweeps), restrv(n_sweeps),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
end if
|
||||
|
||||
|
||||
call acv(0)%mv_from(acsr)
|
||||
call ag%base_desc%clone(desc_acv(0),info)
|
||||
|
||||
else
|
||||
call a%cp_to(acsr)
|
||||
if (ag%do_clean_zeros) call acsr%clean_zeros(info)
|
||||
nr = acsr%get_nrows()
|
||||
if (psb_size(ag%w) < nr) call ag%bld_default_w(nr)
|
||||
isz = acsr%get_ncols()
|
||||
|
||||
call psb_realloc(isz,ixaggr,info)
|
||||
if (info == psb_success_) &
|
||||
& allocate(acv(0:n_sweeps), desc_acv(0:n_sweeps),&
|
||||
& prolv(n_sweeps), restrv(n_sweeps),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
|
||||
end if
|
||||
|
||||
|
||||
call acv(0)%mv_from(acsr)
|
||||
call desc_a%clone(desc_acv(0),info)
|
||||
end if
|
||||
|
||||
nrac = desc_acv(0)%get_local_rows()
|
||||
ncac = desc_acv(0)%get_local_cols()
|
||||
if (debug) write(0,*) me,' On input to level: ',nrac, ncac
|
||||
if (allocated(ag%prol)) then
|
||||
call ag%prol%free()
|
||||
deallocate(ag%prol)
|
||||
end if
|
||||
if (allocated(ag%restr)) then
|
||||
call ag%restr%free()
|
||||
deallocate(ag%restr)
|
||||
end if
|
||||
|
||||
if (dump) then
|
||||
block
|
||||
type(psb_lsspmat_type) :: lac
|
||||
ivr = desc_acv(0)%get_global_indices(owned=.false.)
|
||||
prefix_ = "input_a"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+9),'(a,i3.3,a)') '_p',me, '.mtx'
|
||||
call acv(0)%print(fname,head='Debug aggregates')
|
||||
call lac%cp_from(acv(0))
|
||||
write(fname(lname+1:lname+13),'(a,i3.3,a)') '_p',me, '-glb.mtx'
|
||||
call lac%print(fname,head='Debug aggregates',iv=ivr)
|
||||
call lac%free()
|
||||
end block
|
||||
end if
|
||||
|
||||
call psb_geall(tmpw,desc_acv(0),info)
|
||||
|
||||
tmpw(1:nr) = ag%w(1:nr)
|
||||
|
||||
call psb_geasb(tmpw,desc_acv(0),info)
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),max_csize
|
||||
end if
|
||||
|
||||
!
|
||||
! Prepare ag%ac, ag%desc_ac, ag%prol, ag%restr to enable
|
||||
! shortcuts in mat_bld and mat_asb
|
||||
! and ag%desc_ax which will be needed in backfix.
|
||||
!
|
||||
x_sweeps = -1
|
||||
sweeps_loop: do i=1, n_sweeps
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me==0) write(0,*) me,trim(name),' Start sweeps_loop iteration:',i,' of ',n_sweeps
|
||||
end if
|
||||
|
||||
!
|
||||
! Building prol and restr because this algorithm is not decoupled
|
||||
! On exit from matchbox_build_prol, prolv(i) is in global numbering
|
||||
!
|
||||
!
|
||||
if (debug) write(0,*) me,' Into matchbox_build_prol ',info
|
||||
if (do_timings) call psb_tic(idx_mboxp)
|
||||
call smatchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,&
|
||||
& symmetrize=ag%need_symmetrize,reproducible=ag%reproducible_matching)
|
||||
if (do_timings) call psb_toc(idx_mboxp)
|
||||
if (debug) write(0,*) me,' Out from matchbox_build_prol ',info
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on exit bld_tprol',info
|
||||
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Calling spmm_bld NSW>1:',i,&
|
||||
& desc_acv(i-1)%get_local_rows(),desc_acv(i-1)%get_local_cols(),&
|
||||
& desc_acv(i-1)%get_global_rows()
|
||||
end if
|
||||
if (i == n_sweeps) call tmp_prol%clone(tmp_pg,info)
|
||||
if (do_timings) call psb_tic(idx_spmmbld)
|
||||
!
|
||||
! On entry, prolv(i) is in global numbering,
|
||||
!
|
||||
call amg_s_parmatch_spmm_bld_ov(acv(i-1),desc_acv(i-1),ixaggr,nxaggr,parms,&
|
||||
& acv(i),desc_acv(i), prolv(i),restrv(1),tmp_prol,info)
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on exit from bld_ov(i)',info
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done spmm_bld:',i
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_spmmbld)
|
||||
! Keep a copy of prolv(i) in global numbering for the time being, will
|
||||
! need it to build the final
|
||||
! if (i == n_sweeps) call prolv(i)%clone(tmp_prol,info)
|
||||
!!$ write(0,*) name,' Call mat_asb sweep:',i,n_sweeps
|
||||
call ag%inner_mat_asb(parms,acv(i-1),desc_acv(i-1),&
|
||||
& acv(i),desc_acv(i),prolv(i),restrv(1),info)
|
||||
|
||||
!!$ write(0,*) me,' From in_mat_asb:',&
|
||||
!!$ & prolv(i)%get_nrows(),prolv(i)%get_ncols(),&
|
||||
!!$ & restrv(1)%get_nrows(),restrv(1)%get_ncols(),&
|
||||
!!$ & desc_acv(i)%get_local_rows(), desc_acv(i)%get_local_cols()
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),max_csize,info
|
||||
csz = sum(nxaggr)
|
||||
call psb_bcast(ictxt,csz)
|
||||
if (csz /= sum(nxaggr)) write(0,*) me,trim(name),' Mismatch matasb',&
|
||||
& csz,sum(nxaggr),max_csize
|
||||
end if
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on entry to tmpwnxt 2'
|
||||
|
||||
|
||||
!
|
||||
! Fix wnxt
|
||||
!
|
||||
if (info == 0) call psb_geall(tmpwnxt,desc_acv(i),info)
|
||||
if (info == 0) call psb_geasb(tmpwnxt,desc_acv(i),info,scratch=.true.)
|
||||
if (info == 0) call psb_halo(tmpw,desc_acv(i-1),info)
|
||||
!!$ write(0,*) trestr%get_nrows(),size(tmpwnxt),trestr%get_ncols(),size(tmpw)
|
||||
|
||||
if (info == 0) call psb_csmm(sone,restrv(1),tmpw,szero,tmpwnxt,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
write(0,*)me,trim(name),'Error from mat_asb/tmpw ',info
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='mat_asb 2')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (i == 1) then
|
||||
nrac = desc_acv(1)%get_local_rows()
|
||||
!!$ write(0,*) 'Copying output w_nxt ',nrac
|
||||
call psb_realloc(nrac,ag%w_nxt,info)
|
||||
ag%w_nxt(1:nrac) = tmpwnxt(1:nrac)
|
||||
!
|
||||
! ILAGGR is fixed later on, but
|
||||
! get a copy in case of an early exit
|
||||
!
|
||||
call psb_safe_ab_cpy(ixaggr,ilaggr,info)
|
||||
end if
|
||||
call psb_safe_ab_cpy(nxaggr,nlaggr,info)
|
||||
call move_alloc(tmpwnxt,tmpw)
|
||||
if (debug) then
|
||||
if (csz /= sum(nlaggr)) write(0,*) me,trim(name),' Mismatch 2 matasb',&
|
||||
& csz,sum(nlaggr),max_csize, info
|
||||
end if
|
||||
call acv(i-1)%free()
|
||||
if ((sum(nlaggr) <= max_csize).or.(any(nlaggr==0))) then
|
||||
!if (me==0) write(0,*) 'Early exit ',any(nlaggr==0),sum(nlaggr),max_csize,i
|
||||
x_sweeps = i
|
||||
exit sweeps_loop
|
||||
end if
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done sweeps_loop iteration:',i,' of ',n_sweeps
|
||||
end if
|
||||
|
||||
end do sweeps_loop
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
!!$ write(0,*) name,' Call spmm_bld sweep:',i,n_sweeps
|
||||
if (me==0) write(0,*) me,trim(name),' Done sweeps_loop:',x_sweeps
|
||||
end if
|
||||
!!$ write(0,*) me,name,' : End of aggregation sweeps ',&
|
||||
!!$ & n_sweeps,' Final size:',max_csize,desc_acv(n_sweeps)%get_local_rows(),t_prol%get_ncols(),tmp_prol%get_ncols()
|
||||
if (x_sweeps<=0) x_sweeps = n_sweeps
|
||||
|
||||
if (do_timings) call psb_tic(idx_sweeps_mult)
|
||||
!
|
||||
! Ok, now we have all the prolongators, including the last one in global numbering.
|
||||
! Build the product of all prolongators. Need a tmp_desc_ax
|
||||
! which is correct but most of the time overdimensioned
|
||||
!
|
||||
if (.not.allocated(ag%desc_ax)) allocate(ag%desc_ax)
|
||||
!
|
||||
block
|
||||
integer(psb_ipk_) :: i, nnz
|
||||
integer(psb_lpk_) :: ncol, ncsave
|
||||
if (.not.allocated(ag%ac)) allocate(ag%ac)
|
||||
if (.not.allocated(ag%desc_ac)) allocate(ag%desc_ac)
|
||||
call desc_acv(x_sweeps)%clone(ag%desc_ac,info)
|
||||
call desc_acv(x_sweeps)%free(info)
|
||||
call acv(x_sweeps)%move_alloc(ag%ac,info)
|
||||
!!$ call acv(x_sweeps)%clone(ag%ac,info)
|
||||
if (.not.allocated(ag%prol)) allocate(ag%prol)
|
||||
if (.not.allocated(ag%restr)) allocate(ag%restr)
|
||||
|
||||
!call desc_acv(x_sweeps)%clone(ag%desc_ac,info)
|
||||
call psb_cd_reinit(ag%desc_ac,info)
|
||||
ncsave = ag%desc_ac%get_global_rows()
|
||||
!
|
||||
! Note: prolv(i) is already in local numbering
|
||||
! because of the call to mat_asb in the loop above.
|
||||
!
|
||||
call prolv(x_sweeps)%mv_to(csr_prol)
|
||||
!call csr_prol%set_ncols(ag%desc_ac%get_local_cols())
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'Enter prolongator product loop ',x_sweeps
|
||||
end if
|
||||
|
||||
do i=x_sweeps-1, 1, -1
|
||||
call prolv(i)%mv_to(csr_pvi)
|
||||
if (psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 1'
|
||||
!!$ write(0,*) me,' SPMM1 ',csr_pvi%get_nrows(),csr_pvi%get_ncols(),&
|
||||
!!$ & csr_prol%get_nrows(),csr_prol%get_ncols()
|
||||
call psb_par_spspmm(csr_pvi,desc_acv(i),csr_prol,csr_prod_res,ag%desc_ac,info)
|
||||
if ((info /=0).or.psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 2',info
|
||||
call csr_pvi%free()
|
||||
call csr_prod_res%mv_to_fmt(csr_prol,info)
|
||||
if ((info /=0).or.psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 3',info
|
||||
call csr_prol%set_ncols(ag%desc_ac%get_local_cols())
|
||||
if ((info /=0).or.psb_errstatus_fatal()) write(0,*) me,' Fatal error in prolongator loop 4'
|
||||
end do
|
||||
call csr_prol%mv_to_lfmt(lcsr_prol,info)
|
||||
nnz = lcsr_prol%get_nzeros()
|
||||
call ag%desc_ac%l2gip(lcsr_prol%ja(1:nnz),info)
|
||||
call lcsr_prol%set_ncols(ncsave)
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'Done prolongator product loop ',x_sweeps
|
||||
end if
|
||||
!
|
||||
! Fix ILAGGR here by copying from CSR_PROL%JA
|
||||
!
|
||||
block
|
||||
integer(psb_ipk_) :: nr
|
||||
nr = lcsr_prol%get_nrows()
|
||||
if (nnz /= nr) then
|
||||
write(0,*) me,name,' Issue with prolongator? ',nr,nnz
|
||||
end if
|
||||
call psb_realloc(nr,ilaggr,info)
|
||||
ilaggr(1:nnz) = lcsr_prol%ja(1:nnz)
|
||||
end block
|
||||
call tmp_prol%mv_from(lcsr_prol)
|
||||
call psb_cdasb(ag%desc_ac,info)
|
||||
call ag%ac%set_ncols(ag%desc_ac%get_local_cols())
|
||||
end block
|
||||
|
||||
call tmp_prol%move_alloc(t_prol,info)
|
||||
call t_prol%set_ncols(ag%desc_ac%get_local_cols())
|
||||
call t_prol%set_nrows(desc_acv(0)%get_local_rows())
|
||||
|
||||
nrac = ag%desc_ac%get_local_rows()
|
||||
ncac = ag%desc_ac%get_local_cols()
|
||||
call psb_realloc(nrac,ag%w_nxt,info)
|
||||
ag%w_nxt(1:nrac) = tmpw(1:nrac)
|
||||
|
||||
|
||||
if (do_timings) call psb_toc(idx_sweeps_mult)
|
||||
|
||||
if (debug) then
|
||||
call psb_barrier(ictxt)
|
||||
if (me == 0) write(0,*) 'Out of build loop ',x_sweeps,': Output size:',sum(nlaggr)
|
||||
end if
|
||||
|
||||
|
||||
!call psb_set_debug_level(0)
|
||||
if (dump) then
|
||||
block
|
||||
ivr = desc_acv(x_sweeps)%get_global_indices(owned=.false.)
|
||||
prefix_ = "final_ac"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+9),'(a,i3.3,a)') '_p',me, '.mtx'
|
||||
call acv(x_sweeps)%print(fname,head='Debug aggregates')
|
||||
write(fname(lname+1:lname+13),'(a,i3.3,a)') '_p',me, '-glb.mtx'
|
||||
call acv(x_sweeps)%print(fname,head='Debug aggregates',iv=ivr)
|
||||
prefix_ = "final_tp"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+9),'(a,i3.3,a)') '_p',me, '.mtx'
|
||||
call t_prol%print(fname,head='Tentative prolongator')
|
||||
end block
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_bootCMatch_if')
|
||||
goto 9999
|
||||
end if
|
||||
!!$ write(0,*)me,' ',name,' Getting out with info ',info,&
|
||||
!!$ & allocated(ilaggr),psb_size(ilaggr),allocated(nlaggr),psb_size(nlaggr)
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
contains
|
||||
subroutine do_l1_jacobi(nsweeps,w,a,desc_a)
|
||||
integer(psb_ipk_), intent(in) :: nsweeps
|
||||
real(psb_dpk_), intent(inout) :: w(:)
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
|
||||
end subroutine do_l1_jacobi
|
||||
end subroutine amg_s_parmatch_aggregator_build_tprol
|
||||
@ -0,0 +1,414 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_saggrmat_smth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_saggrmat_smth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is a prolongator from the coarse level to the fine one.
|
||||
!
|
||||
! The prolongator P_C is built according to a smoothed aggregation algorithm,
|
||||
! i.e. it is obtained by applying a damped Jacobi smoother to the piecewise
|
||||
! constant interpolation operator P corresponding to the fine-to-coarse level
|
||||
! mapping built by the amg_aggrmap_bld subroutine:
|
||||
!
|
||||
! P_C = (I - omega*D^(-1)A) * P,
|
||||
!
|
||||
! where D is the diagonal matrix with main diagonal equal to the main diagonal
|
||||
! of A, and omega is a suitable smoothing parameter. An estimate of the spectral
|
||||
! radius of D^(-1)A, to be used in the computation of omega, is provided,
|
||||
! according to the value of p%parms%aggr_omega_alg, specified by the user
|
||||
! through amg_sprecinit and amg_zprecset.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat,
|
||||
! specified by the user through amg_sprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
! aggregator%mat_bld.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_s_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_sml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_sspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_s_inner_mod
|
||||
use amg_s_base_aggregator_mod
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_smth_bld
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: op_prol,ac,op_restr
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
|
||||
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
|
||||
integer(psb_ipk_) :: inaggr
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
character(len=20) :: name
|
||||
type(psb_ls_coo_sparse_mat) :: tmpcoo, ac_coo, lcoo_restr
|
||||
type(psb_s_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
type(psb_s_csr_sparse_mat) :: acsrf, csr_prol, acsr, tcsr
|
||||
real(psb_spk_), allocatable :: adiag(:)
|
||||
real(psb_spk_), allocatable :: arwsum(:)
|
||||
logical :: filter_mat
|
||||
integer(psb_ipk_) :: debug_level, debug_unit, err_act
|
||||
integer(psb_ipk_), parameter :: ncmax=16
|
||||
real(psb_spk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false., dump_r=.false., dump_p=.false., debug=.false.
|
||||
character(len=80) :: filename
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1, idx_phase3=-1
|
||||
integer(psb_ipk_), save :: idx_cdasb=-1, idx_ptap=-1
|
||||
|
||||
name='amg_parmatch_smth_bld'
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
!debug_level = 2
|
||||
ictxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
theta = parms%aggr_thresh
|
||||
!write(0,*) me,' ',trim(name),' Start ',idx_spspmm
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("PMC_SMTH_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_phase1==-1)) &
|
||||
& idx_phase1 = psb_get_timer_idx("PMC_SMTH_BLD: phase1 ")
|
||||
if ((do_timings).and.(idx_phase2==-1)) &
|
||||
& idx_phase2 = psb_get_timer_idx("PMC_SMTH_BLD: phase2 ")
|
||||
if ((do_timings).and.(idx_phase3==-1)) &
|
||||
& idx_phase3 = psb_get_timer_idx("PMC_SMTH_BLD: phase3 ")
|
||||
if ((do_timings).and.(idx_gtrans==-1)) &
|
||||
& idx_gtrans = psb_get_timer_idx("PMC_SMTH_BLD: gtrans ")
|
||||
if ((do_timings).and.(idx_refine==-1)) &
|
||||
& idx_refine = psb_get_timer_idx("PMC_SMTH_BLD: refine ")
|
||||
if ((do_timings).and.(idx_cdasb==-1)) &
|
||||
& idx_cdasb = psb_get_timer_idx("PMC_SMTH_BLD: cdasb ")
|
||||
if ((do_timings).and.(idx_ptap==-1)) &
|
||||
& idx_ptap = psb_get_timer_idx("PMC_SMTH_BLD: ptap_bld ")
|
||||
|
||||
if (do_timings) call psb_tic(idx_phase1)
|
||||
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
naggrm1 = sum(nlaggr(1:me))
|
||||
naggrp1 = sum(nlaggr(1:me+1))
|
||||
filter_mat = (parms%aggr_filter == amg_filter_mat_)
|
||||
|
||||
!
|
||||
! naggr: number of local aggregates
|
||||
! nrow: local rows.
|
||||
!
|
||||
if (dump_p) then
|
||||
block
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
integer(psb_lpk_) :: i
|
||||
character(len=132) :: aname
|
||||
type(psb_lsspmat_type) :: aglob
|
||||
type(psb_sspmat_type) :: atmp
|
||||
!!$ call a%cp_to(acsr)
|
||||
!!$ call atmp%cp_from(acsr)
|
||||
write(0,*) me,' ',trim(name),' Dumping inp_prol/restr'
|
||||
write(aname,'(a,i0,a,i0,a)') 'tprol-',desc_a%get_global_rows(),'-p',me,'.mtx'
|
||||
call t_prol%print(fname=aname,head='Test ')
|
||||
end block
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_refine)
|
||||
! Get the diagonal D
|
||||
adiag = a%get_diag(info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_realloc(ncol,adiag,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_halo(adiag,desc_a,info)
|
||||
if (info == psb_success_) call a%cp_to(acsr)
|
||||
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Initial copies done.'
|
||||
|
||||
call acsr%cp_to_fmt(acsrf,info)
|
||||
|
||||
if (filter_mat) then
|
||||
!
|
||||
! Build the filtered matrix Af from A
|
||||
!
|
||||
|
||||
do i=1, nrow
|
||||
tmp = dzero
|
||||
jd = -1
|
||||
do j=acsrf%irp(i),acsrf%irp(i+1)-1
|
||||
if (acsrf%ja(j) == i) jd = j
|
||||
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
|
||||
tmp=tmp+acsrf%val(j)
|
||||
acsrf%val(j)=dzero
|
||||
endif
|
||||
|
||||
enddo
|
||||
if (jd == -1) then
|
||||
write(0,*) 'Wrong input: we need the diagonal!!!!', i
|
||||
else
|
||||
acsrf%val(jd)=acsrf%val(jd)-tmp
|
||||
end if
|
||||
enddo
|
||||
! Take out zeroed terms
|
||||
call acsrf%clean_zeros(info)
|
||||
end if
|
||||
|
||||
|
||||
do i=1,size(adiag)
|
||||
if (adiag(i) /= dzero) then
|
||||
adiag(i) = done / adiag(i)
|
||||
else
|
||||
adiag(i) = done
|
||||
end if
|
||||
end do
|
||||
if (do_timings) call psb_toc(idx_refine)
|
||||
|
||||
if (parms%aggr_omega_alg == amg_eig_est_) then
|
||||
|
||||
if (parms%aggr_eig == amg_max_norm_) then
|
||||
allocate(arwsum(nrow))
|
||||
call acsr%arwsum(arwsum)
|
||||
anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
|
||||
call psb_amx(ictxt,anorm)
|
||||
omega = 4.d0/(3.d0*anorm)
|
||||
parms%aggr_omega_val = omega
|
||||
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_eig_')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (parms%aggr_omega_alg == amg_user_choice_) then
|
||||
|
||||
omega = parms%aggr_omega_val
|
||||
|
||||
else if (parms%aggr_omega_alg /= amg_user_choice_) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
call acsrf%scal(adiag,info)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Filtering and scaling done.',info
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
inaggr = naggr
|
||||
|
||||
call t_prol%cp_to(tmpcoo)
|
||||
|
||||
call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzl),info)
|
||||
call tmpcoo%set_ncols(desc_ac%get_local_cols())
|
||||
call tmpcoo%mv_to_ifmt(tcsr,info)
|
||||
!
|
||||
! Build the smoothed prolongator using either A or Af
|
||||
! csr_prol = (I-w*D*A) Prol csr_prol = (I-w*D*Af) Prol
|
||||
! This is always done through the variable acsrf which
|
||||
! is a bit less readable, but saves space and one extra matrix copy
|
||||
!
|
||||
call omega_smooth(omega,acsrf)
|
||||
if (do_timings) call psb_toc(idx_phase1)
|
||||
|
||||
if (do_timings) call psb_tic(idx_spspmm)
|
||||
call psb_par_spspmm(acsrf,desc_a,tcsr,csr_prol,desc_ac,info)
|
||||
call tcsr%free()
|
||||
if (do_timings) call psb_toc(idx_spspmm)
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Now that we have the smoothed prolongator, we can
|
||||
! compute the triple product.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_cdasb)
|
||||
call psb_cdasb(desc_ac,info)
|
||||
if (do_timings) call psb_toc(idx_cdasb)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
|
||||
call csr_prol%mv_to_coo(coo_prol,info)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done SPSPMM 1'
|
||||
|
||||
if (do_timings) call psb_tic(idx_ptap)
|
||||
if (.not.allocated(ag%desc_ax)) allocate(ag%desc_ax)
|
||||
call amg_ptap_bld(acsr,desc_a,nlaggr,parms,ac,&
|
||||
& coo_prol,desc_ac,coo_restr,info,desc_ax=ag%desc_ax)
|
||||
if (do_timings) call psb_toc(idx_ptap)
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus()
|
||||
if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
|
||||
! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
|
||||
|
||||
if (dump_r) then
|
||||
block
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
integer(psb_lpk_) :: i
|
||||
character(len=132) :: aname
|
||||
type(psb_lsspmat_type) :: aglob
|
||||
type(psb_sspmat_type) :: atmp
|
||||
write(0,*) me,' ',trim(name),' Dumping prol/restr'
|
||||
ivc = [(i,i=1,desc_a%get_local_cols())]
|
||||
call desc_a%l2gip(ivc,info)
|
||||
ivr = [(i,i=1,desc_ac%get_local_cols())]
|
||||
call desc_ac%l2gip(ivr,info)
|
||||
|
||||
write(aname,'(a,i0,a,i0,a)') 'restr-',desc_ac%get_global_rows(),'-p',me,'.mtx'
|
||||
|
||||
call op_restr%print(fname=aname,head='Test ',ivc=ivc)
|
||||
!!$ write(aname,'(a,i0,a,i0,a)') 'prol-',desc_ac%get_global_rows(),'-p',me,'.mtx'
|
||||
!!$ call op_prol%print(fname=aname,head='Test ')
|
||||
!!$ call psb_gather(aglob,atmp,desc_a,info)
|
||||
!!$ if (me==psb_root_) then
|
||||
!!$ write(aname,'(a,i0,a)') 'a-inp-g-',aglob%get_nrows(),'.mtx'
|
||||
!!$ call aglob%print(fname=aname,head='Test ')
|
||||
!!$ end if
|
||||
|
||||
end block
|
||||
end if
|
||||
if (do_timings) call psb_toc(idx_phase2)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine omega_smooth(omega,acsr)
|
||||
implicit none
|
||||
real(psb_spk_),intent(in) :: omega
|
||||
type(psb_s_csr_sparse_mat), intent(inout) :: acsr
|
||||
!
|
||||
integer(psb_ipk_) :: i,j
|
||||
do i=1,acsr%get_nrows()
|
||||
do j=acsr%irp(i),acsr%irp(i+1)-1
|
||||
if (acsr%ja(j) == i) then
|
||||
acsr%val(j) = done - omega*acsr%val(j)
|
||||
else
|
||||
acsr%val(j) = - omega*acsr%val(j)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
end subroutine omega_smooth
|
||||
|
||||
end subroutine amg_s_parmatch_smth_bld
|
||||
@ -0,0 +1,194 @@
|
||||
! !
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! moved here from
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_saggrmat_nosmth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_saggrmat_nosmth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is the piecewise constant interpolation operator corresponding
|
||||
! the fine-to-coarse level mapping built by amg_aggrmap_bld.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat
|
||||
! specified by the user through amg_sprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
!
|
||||
! For details see
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
|
||||
! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math.,
|
||||
! 57 (2007), 1181-1196.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_s_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_sml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_sspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_s_inner_mod
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_spmm_bld
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(inout) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np,me
|
||||
character(len=20) :: name
|
||||
type(psb_s_csr_sparse_mat) :: acsr
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
|
||||
& naggr, nzt, naggrm1, naggrp1, i, k
|
||||
integer(psb_ipk_) :: inaggr, nzlp
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='amg_parmatch_spmm_bld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
call a%cp_to(acsr)
|
||||
|
||||
call amg_s_parmatch_spmm_bld_inner(acsr,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err="SPMM_BLD_INNER")
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done spmm_bld '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_s_parmatch_spmm_bld
|
||||
@ -0,0 +1,210 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_saggrmat_nosmth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_saggrmat_nosmth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is the piecewise constant interpolation operator corresponding
|
||||
! the fine-to-coarse level mapping built by amg_aggrmap_bld.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat
|
||||
! specified by the user through amg_sprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
!
|
||||
! For details see
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
|
||||
! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math.,
|
||||
! 57 (2007), 1181-1196.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_s_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_sml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_sspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_s_inner_mod
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_spmm_bld_inner
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
type(psb_s_csr_sparse_mat), intent(inout) :: a_csr
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(out) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me, ndx
|
||||
character(len=40) :: name
|
||||
type(psb_ls_coo_sparse_mat) :: tmpcoo
|
||||
type(psb_s_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
type(psb_s_csr_sparse_mat) :: ac_csr, csr_restr
|
||||
type(psb_desc_type), target :: tmp_desc
|
||||
type(psb_lsspmat_type) :: lac
|
||||
integer(psb_ipk_) :: debug_level, debug_unit, naggr
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nrl, nzl, ip, &
|
||||
& nzt, naggrm1, naggrp1, i, k
|
||||
integer(psb_lpk_), allocatable :: ia(:),ja(:)
|
||||
!integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza, nrpsave, ncpsave, nzpsave
|
||||
logical, parameter :: do_timings=.true., oldstyle=.false., debug=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_prolcnv=-1, idx_proltrans=-1, idx_asb=-1
|
||||
|
||||
name='amg_parmatch_spmm_bld_inner'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("SPMM_BLD: spspmm ")
|
||||
if ((do_timings).and.(idx_prolcnv==-1)) &
|
||||
& idx_prolcnv = psb_get_timer_idx("SPMM_BLD: prolcnv ")
|
||||
if ((do_timings).and.(idx_proltrans==-1)) &
|
||||
& idx_proltrans = psb_get_timer_idx("SPMM_BLD: proltrans")
|
||||
if ((do_timings).and.(idx_asb==-1)) &
|
||||
& idx_asb = psb_get_timer_idx("SPMM_BLD: asb ")
|
||||
|
||||
if (do_timings) call psb_tic(idx_prolcnv)
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
naggrm1 = sum(nlaggr(1:me))
|
||||
naggrp1 = sum(nlaggr(1:me+1))
|
||||
|
||||
!
|
||||
! Here T_PROL should be arriving with GLOBAL indices on the cols
|
||||
! and LOCAL indices on the rows.
|
||||
!
|
||||
if (debug) write(0,*) me,' ',trim(name),' Size check on entry New: ',&
|
||||
& op_prol%get_fmt(),op_prol%get_nrows(),op_prol%get_ncols(),op_prol%get_nzeros(),&
|
||||
& nrow,ntaggr,naggr
|
||||
|
||||
call t_prol%cp_to(tmpcoo)
|
||||
|
||||
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
|
||||
nzl = tmpcoo%get_nzeros()
|
||||
if (debug) write(0,*) me,' ',trim(name),' coo_prol: ',&
|
||||
& tmpcoo%ia(1:min(10,nzl)),' :',tmpcoo%ja(1:min(10,nzl))
|
||||
call desc_ac%indxmap%g2lip_ins(tmpcoo%ja(1:nzl),info)
|
||||
call tmpcoo%set_ncols(desc_ac%get_local_cols())
|
||||
call tmpcoo%cp_to_icoo(coo_prol,info)
|
||||
|
||||
call amg_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
& coo_prol,desc_ac,coo_restr,info)
|
||||
|
||||
nzl = coo_prol%get_nzeros()
|
||||
if (debug) write(0,*) me,' ',trim(name),' coo_prol: ',&
|
||||
& coo_prol%ia(1:min(10,nzl)),' :',coo_prol%ja(1:min(10,nzl))
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
if (debug) then
|
||||
write(0,*) me,' ',trim(name),' Checkpoint at exit'
|
||||
call psb_barrier(ictxt)
|
||||
write(0,*) me,' ',trim(name),' Checkpoint through'
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x a3')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_s_parmatch_spmm_bld_inner
|
||||
@ -0,0 +1,180 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS Extensions
|
||||
!
|
||||
! (C) Copyright 2019
|
||||
!
|
||||
! Salvatore Filippone Cranfield University
|
||||
! Pasqua D'Ambra IAC-CNR, Naples, IT
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_saggrmat_nosmth_bld_ov.F90
|
||||
!
|
||||
! Subroutine: amg_saggrmat_nosmth_bld_ov
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is the piecewise constant interpolation operator corresponding
|
||||
! the fine-to-coarse level mapping built by amg_aggrmap_bld_ov.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat
|
||||
! specified by the user through amg_sprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
!
|
||||
! For details see
|
||||
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
|
||||
! PSBLAS-based parallel two-level Schwarz preconditioners, Appl. Num. Math.,
|
||||
! 57 (2007), 1181-1196.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_s_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_sml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_sspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_s_inner_mod
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_spmm_bld_ov
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
type(psb_sspmat_type), intent(inout) :: a
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_sspmat_type), intent(inout) :: ac, op_prol, op_restr
|
||||
type(psb_desc_type), intent(out) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
character(len=20) :: name
|
||||
type(psb_s_csr_sparse_mat) :: acsr
|
||||
type(psb_ls_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
|
||||
& naggr, nzt, naggrm1, naggrp1, i, k
|
||||
integer(psb_ipk_) :: inaggr, nzlp
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical, parameter :: debug=.false., new_version=.true.
|
||||
|
||||
name='amg_parmatch_spmm_bld_ov'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
call a%mv_to(acsr)
|
||||
|
||||
call amg_s_parmatch_spmm_bld_inner(acsr,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on exit from bld_inner',info
|
||||
|
||||
!!$ else
|
||||
!!$ naggr = nlaggr(me+1)
|
||||
!!$ ntaggr = sum(nlaggr)
|
||||
!!$ naggrm1 = sum(nlaggr(1:me))
|
||||
!!$ naggrp1 = sum(nlaggr(1:me+1))
|
||||
!!$ call op_prol%mv_to(coo_prol)
|
||||
!!$ inaggr = naggr
|
||||
!!$ call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
|
||||
!!$ nzlp = coo_prol%get_nzeros()
|
||||
!!$ call desc_ac%indxmap%g2lip_ins(coo_prol%ja(1:nzlp),info)
|
||||
!!$ call coo_prol%set_ncols(desc_ac%get_local_cols())
|
||||
!!$ call amg_spmm_bld_inner(acsr,desc_a,nlaggr,parms,ac,&
|
||||
!!$ & coo_prol,desc_ac,coo_restr,info)
|
||||
!!$ call psb_cdasb(desc_ac,info)
|
||||
!!$ !call desc_ac%free(info)
|
||||
!!$ !write(0,*) me, 'Size of nlaggr',size(nlaggr),nlaggr(1)
|
||||
!!$ call op_prol%mv_from(coo_prol)
|
||||
!!$ call op_restr%mv_from(coo_restr)
|
||||
!!$
|
||||
!!$ end if
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err="SPMM_BLD_INNER")
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done spmm_bld '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_s_parmatch_spmm_bld_ov
|
||||
@ -0,0 +1,251 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
! File: amg_s_parmatch_unsmth_bld.F90
|
||||
!
|
||||
! Subroutine: amg_s_parmatch_unsmth_bld
|
||||
! Version: real
|
||||
!
|
||||
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
|
||||
! by using the Galerkin approach, i.e.
|
||||
!
|
||||
! A_C = P_C^T A P_C,
|
||||
!
|
||||
! where P_C is a prolongator from the coarse level to the fine one.
|
||||
!
|
||||
! The prolongator P_C is built according to a smoothed aggregation algorithm,
|
||||
! i.e. it is obtained by applying a damped Jacobi smoother to the piecewise
|
||||
! constant interpolation operator P corresponding to the fine-to-coarse level
|
||||
! mapping built by the amg_aggrmap_bld subroutine:
|
||||
!
|
||||
! P_C = (I - omega*D^(-1)A) * P,
|
||||
!
|
||||
! where D is the diagonal matrix with main diagonal equal to the main diagonal
|
||||
! of A, and omega is a suitable smoothing parameter. An estimate of the spectral
|
||||
! radius of D^(-1)A, to be used in the computation of omega, is provided,
|
||||
! according to the value of p%parms%aggr_omega_alg, specified by the user
|
||||
! through amg_sprecinit and amg_zprecset.
|
||||
!
|
||||
! The coarse-level matrix A_C is distributed among the parallel processes or
|
||||
! replicated on each of them, according to the value of p%parms%coarse_mat,
|
||||
! specified by the user through amg_sprecinit and amg_zprecset.
|
||||
! On output from this routine the entries of AC, op_prol, op_restr
|
||||
! are still in "global numbering" mode; this is fixed in the calling routine
|
||||
! aggregator%mat_bld.
|
||||
!
|
||||
!
|
||||
! Arguments:
|
||||
! a - type(psb_sspmat_type), input.
|
||||
! The sparse matrix structure containing the local part of
|
||||
! the fine-level matrix.
|
||||
! desc_a - type(psb_desc_type), input.
|
||||
! The communication descriptor of the fine-level matrix.
|
||||
! p - type(amg_s_onelev_type), input/output.
|
||||
! The 'one-level' data structure that will contain the local
|
||||
! part of the matrix to be built as well as the information
|
||||
! concerning the prolongator and its transpose.
|
||||
! parms - type(amg_sml_parms), input
|
||||
! Parameters controlling the choice of algorithm
|
||||
! ac - type(psb_sspmat_type), output
|
||||
! The coarse matrix on output
|
||||
!
|
||||
! ilaggr - integer, dimension(:), input
|
||||
! The mapping between the row indices of the coarse-level
|
||||
! matrix and the row indices of the fine-level matrix.
|
||||
! ilaggr(i)=j means that node i in the adjacency graph
|
||||
! of the fine-level matrix is mapped onto node j in the
|
||||
! adjacency graph of the coarse-level matrix. Note that the indices
|
||||
! are assumed to be shifted so as to make sure the ranges on
|
||||
! the various processes do not overlap.
|
||||
! nlaggr - integer, dimension(:) input
|
||||
! nlaggr(i) contains the aggregates held by process i.
|
||||
! op_prol - type(psb_sspmat_type), input/output
|
||||
! The tentative prolongator on input, the computed prolongator on output
|
||||
!
|
||||
! op_restr - type(psb_sspmat_type), output
|
||||
! The restrictor operator; normally, it is the transpose of the prolongator.
|
||||
!
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
|
||||
& ac,desc_ac,op_prol,op_restr,t_prol,info)
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_s_inner_mod
|
||||
use amg_s_base_aggregator_mod
|
||||
use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_unsmth_bld
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
|
||||
type(amg_sml_parms), intent(inout) :: parms
|
||||
type(psb_sspmat_type), intent(inout) :: op_prol,ac,op_restr
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
type(psb_desc_type), intent(inout) :: desc_ac
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
|
||||
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
|
||||
integer(psb_ipk_) :: inaggr
|
||||
type(psb_ctxt_type) :: ictxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
character(len=20) :: name
|
||||
type(psb_ls_coo_sparse_mat) :: lcoo_prol
|
||||
type(psb_s_coo_sparse_mat) :: coo_prol, coo_restr
|
||||
type(psb_s_csr_sparse_mat) :: acsr
|
||||
type(psb_s_csr_sparse_mat) :: csr_prol, acsr3, csr_restr, ac_csr
|
||||
real(psb_spk_), allocatable :: adiag(:)
|
||||
real(psb_spk_), allocatable :: arwsum(:)
|
||||
logical :: filter_mat
|
||||
integer(psb_ipk_) :: debug_level, debug_unit, err_act
|
||||
integer(psb_ipk_), parameter :: ncmax=16
|
||||
real(psb_spk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false., dump_r=.false., dump_p=.false., debug=.false.
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1
|
||||
character(len=80) :: filename
|
||||
|
||||
name='amg_parmatch_unsmth_bld'
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
ictxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ictxt, me, np)
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
theta = parms%aggr_thresh
|
||||
!write(0,*) me,' ',trim(name),' Start '
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("PMC_UNSMTH_BLD: par_spspmm")
|
||||
|
||||
!
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
naggrm1 = sum(nlaggr(1:me))
|
||||
naggrp1 = sum(nlaggr(1:me+1))
|
||||
!write(0,*) me,' ',trim(name),' input sizes',nlaggr(:),':',naggr
|
||||
|
||||
call a%cp_to(acsr)
|
||||
call t_prol%mv_to(lcoo_prol)
|
||||
|
||||
inaggr = naggr
|
||||
call psb_cdall(ictxt,desc_ac,info,nl=inaggr)
|
||||
nzl = lcoo_prol%get_nzeros()
|
||||
call desc_ac%indxmap%g2lip_ins(lcoo_prol%ja(1:nzl),info)
|
||||
call lcoo_prol%set_ncols(desc_ac%get_local_cols())
|
||||
call lcoo_prol%cp_to_icoo(coo_prol,info)
|
||||
|
||||
if (debug) call check_coo(me,trim(name)//' Check 1 on coo_prol:',coo_prol)
|
||||
|
||||
call psb_cdasb(desc_ac,info)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
if (.not.allocated(ag%desc_ax)) allocate(ag%desc_ax)
|
||||
|
||||
call amg_ptap_bld(acsr,desc_a,nlaggr,parms,ac,&
|
||||
& coo_prol,desc_ac,coo_restr,info,desc_ax=ag%desc_ax)
|
||||
|
||||
call op_restr%cp_from(coo_restr)
|
||||
call op_prol%mv_from(coo_prol)
|
||||
|
||||
if (debug) write(0,*) me,' ',trim(name),' After mv_from',psb_get_errstatus()
|
||||
if (debug) write(0,*) me,' ',trim(name),' ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros(),naggr,ntaggr
|
||||
! write(0,*) me,' ',trim(name),' Final AC newstyle ',ac%get_fmt(),ac%get_nrows(),ac%get_ncols(),ac%get_nzeros()
|
||||
|
||||
if (debug) then
|
||||
write(0,*) me,' ',trim(name),' Checkpoint at exit'
|
||||
call psb_barrier(ictxt)
|
||||
write(0,*) me,' ',trim(name),' Checkpoint through'
|
||||
block
|
||||
character(len=128) :: fname, prefix_
|
||||
integer :: lname
|
||||
prefix_ = "unsmth_bld_"
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+10),'(a,i3.3,a)') '_p_',me, '.mtx'
|
||||
call op_prol%print(fname,head='Debug aggregates')
|
||||
write(fname(lname+1:lname+10),'(a,i3.3,a)') '_r_',me, '.mtx'
|
||||
call op_restr%print(fname,head='Debug aggregates')
|
||||
write(fname(lname+1:lname+11),'(a,i3.3,a)') '_ac_',me, '.mtx'
|
||||
call ac%print(fname,head='Debug aggregates')
|
||||
end block
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = coo_restr x am3')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_errpush(info,name)
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
subroutine check_coo(me,string,coo)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: me
|
||||
type(psb_s_coo_sparse_mat) :: coo
|
||||
character(len=*) :: string
|
||||
integer(psb_lpk_) :: nr,nc,nz
|
||||
nr = coo%get_nrows()
|
||||
nc = coo%get_ncols()
|
||||
nz = coo%get_nzeros()
|
||||
write(0,*) me,string,nr,nc,&
|
||||
& minval(coo%ia(1:nz)),maxval(coo%ia(1:nz)),&
|
||||
& minval(coo%ja(1:nz)),maxval(coo%ja(1:nz))
|
||||
end subroutine check_coo
|
||||
|
||||
end subroutine amg_s_parmatch_unsmth_bld
|
||||
@ -0,0 +1,199 @@
|
||||
// ***********************************************************************
|
||||
//
|
||||
// MatchboxP: A C++ library for approximate weighted matching
|
||||
// Mahantesh Halappanavar (hala@pnnl.gov)
|
||||
// Pacific Northwest National Laboratory
|
||||
//
|
||||
// ***********************************************************************
|
||||
//
|
||||
// Copyright (2021) Battelle Memorial Institute
|
||||
// All rights reserved.
|
||||
//
|
||||
// Redistribution and use in source and binary forms, with or without
|
||||
// modification, are permitted provided that the following conditions
|
||||
// are met:
|
||||
//
|
||||
// 1. Redistributions of source code must retain the above copyright
|
||||
// notice, this list of conditions and the following disclaimer.
|
||||
//
|
||||
// 2. Redistributions in binary form must reproduce the above copyright
|
||||
// notice, this list of conditions and the following disclaimer in the
|
||||
// documentation and/or other materials provided with the distribution.
|
||||
//
|
||||
// 3. Neither the name of the copyright holder nor the names of its
|
||||
// contributors may be used to endorse or promote products derived from
|
||||
// this software without specific prior written permission.
|
||||
//
|
||||
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
||||
// FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
// COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
// INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
||||
// BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
// LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
// LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
// POSSIBILITY OF SUCH DAMAGE.
|
||||
//
|
||||
// ************************************************************************
|
||||
|
||||
#ifndef _static_Queue_
|
||||
#define _static_Queue_
|
||||
|
||||
#include "primitiveDataTypeDefinitions.h"
|
||||
#include "preProcessorDirectives.h"
|
||||
|
||||
using namespace std;
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
/* STATIC QUEUE/STACK CLASS */
|
||||
/*
|
||||
Objective:
|
||||
* Provide a Static Queue/Stack Implementation:
|
||||
Rationale:
|
||||
* Since dynamic memory allocation can be expensive, we want to provide Queue
|
||||
implementation that initializes data only once.
|
||||
Assumption:
|
||||
* The maximum size of the number of elements that can ever be in the Queue is
|
||||
know apriori.
|
||||
* Supports elements only of type Integer (regular or long)
|
||||
* Will add one extra element to the vector ( maxSize + 1 ) to wrap around
|
||||
Functions Provided:
|
||||
- Default Constructor : O(C)
|
||||
- Constructor with given size : O(N) (will have N+1 capacity, for wrap around)
|
||||
- push_back(i) : O(C)
|
||||
- front() : O(C)
|
||||
- pop_front() : O(C) : !!! Modified, will return the element !!!
|
||||
- empty() : O(C)
|
||||
- clear() : O(C) //O(N): in regular case
|
||||
- back() : O(C)
|
||||
- pop_back() : O(C) : !!! Modified, will return the element !!!
|
||||
- size(): O(C)
|
||||
*/
|
||||
class staticQueue
|
||||
{
|
||||
private:
|
||||
vector<MilanLongInt> squeue;
|
||||
MilanLongInt squeueHead;
|
||||
MilanLongInt squeueTail;
|
||||
MilanLongInt NumNodes;
|
||||
|
||||
//Prevent Assignment and Pass by Value:
|
||||
staticQueue(const staticQueue& src);
|
||||
staticQueue& operator=(const staticQueue& rhs);
|
||||
|
||||
public:
|
||||
//Constructors and Destructors
|
||||
staticQueue() { squeueHead = 0; squeueTail = 0; NumNodes = 0; } //Default Constructor
|
||||
staticQueue(MilanLongInt maxSize) //MaximumSize
|
||||
{
|
||||
squeueHead = 0; //Head of the static Stack
|
||||
squeueTail = 0; //Tail of the Statuc Stack
|
||||
NumNodes = maxSize;
|
||||
try
|
||||
{
|
||||
squeue.reserve(NumNodes+1); //The number of nodes plus one to swap around
|
||||
}
|
||||
catch ( length_error )
|
||||
{
|
||||
cerr<<"Within Function: staticQueue(MilanLongInt maxSize) \n";
|
||||
cerr<<"Error: Not enough memory to allocate for Queue \n";
|
||||
exit(1);
|
||||
}
|
||||
squeue.resize( NumNodes+1, -1 ); //Initialize the stack with -1
|
||||
}
|
||||
~staticQueue() {}; //The destructor
|
||||
|
||||
//Access:
|
||||
MilanLongInt front() { return squeue[squeueHead]; } //Non destructive
|
||||
MilanLongInt back()
|
||||
{
|
||||
if ( squeueTail == 0 ) //make it wrap around
|
||||
return squeue[NumNodes];
|
||||
else
|
||||
return squeue[squeueTail-1];
|
||||
}
|
||||
MilanLongInt getHead() { return squeueHead; }
|
||||
MilanLongInt getTail() { return squeueTail; }
|
||||
|
||||
//Manipulation:
|
||||
void push_back(MilanLongInt newElement)
|
||||
{
|
||||
//Q.push_back(i);
|
||||
squeue[squeueTail] = newElement;
|
||||
squeueTail = (squeueTail+1)%(NumNodes+1);
|
||||
}
|
||||
MilanLongInt pop_front() // !!! Modified, will return the element !!!
|
||||
{
|
||||
//Q.pop_front();
|
||||
MilanLongInt U = squeue[squeueHead];
|
||||
squeueHead = (squeueHead+1)%(NumNodes+1);
|
||||
return U;
|
||||
}
|
||||
MilanLongInt pop_back() //!!! Modified, will return the element !!!
|
||||
{
|
||||
//S.pop_back();
|
||||
if ( squeueTail == 0 ) //make it wrap around
|
||||
squeueTail = NumNodes;
|
||||
else
|
||||
squeueTail = (squeueTail-1); //Remove the last element
|
||||
return squeue[squeueTail]; //Needs to be here. Because, the tail always points to the
|
||||
//counter after the last existing element.
|
||||
}
|
||||
void clear()
|
||||
{
|
||||
//Q.clear(); //Empty the Queue
|
||||
squeueHead = 0; //Head of the static Queue
|
||||
squeueTail = 0; //Tail of the Statuc Queue
|
||||
}
|
||||
|
||||
//Query:
|
||||
MilanBool empty()
|
||||
{
|
||||
//Q.empty();
|
||||
if ( squeueHead == squeueTail )
|
||||
return true;
|
||||
else
|
||||
return false;
|
||||
} //end of empty()
|
||||
MilanLongInt size()
|
||||
{
|
||||
//Q.size();
|
||||
MilanLongInt size = 0;
|
||||
if ( squeueHead == squeueTail )
|
||||
return size;
|
||||
else
|
||||
if ( squeueHead < squeueTail )
|
||||
return ( squeueTail - squeueHead );
|
||||
else
|
||||
return ( NumNodes + 1 - squeueHead + squeueTail );
|
||||
} //End of size()
|
||||
void display()
|
||||
{
|
||||
//Q.display();
|
||||
MilanLongInt i=0;
|
||||
cout<<"Queue: "<<endl;
|
||||
if ( squeueHead == squeueTail )
|
||||
cout<<"Empty"<<endl;
|
||||
else
|
||||
if ( squeueHead < squeueTail )
|
||||
{
|
||||
for ( i=squeueHead; i<squeueTail; i++ )
|
||||
cout<<squeue[i]<<", ";
|
||||
cout<<endl;
|
||||
}
|
||||
else
|
||||
{
|
||||
for ( i=squeueHead; i<NumNodes; i++)
|
||||
cout<<squeue[i]<<", ";
|
||||
for ( i=0; i<squeueTail; i++)
|
||||
cout<<squeue[i]<<", ";
|
||||
cout<<endl;
|
||||
}
|
||||
} //End of display()
|
||||
|
||||
};
|
||||
|
||||
#endif
|
||||
@ -0,0 +1,79 @@
|
||||
// ***********************************************************************
|
||||
//
|
||||
// MatchboxP: A C++ library for approximate weighted matching
|
||||
// Mahantesh Halappanavar (hala@pnnl.gov)
|
||||
// Pacific Northwest National Laboratory
|
||||
//
|
||||
// ***********************************************************************
|
||||
//
|
||||
// Copyright (2021) Battelle Memorial Institute
|
||||
// All rights reserved.
|
||||
//
|
||||
// Redistribution and use in source and binary forms, with or without
|
||||
// modification, are permitted provided that the following conditions
|
||||
// are met:
|
||||
//
|
||||
// 1. Redistributions of source code must retain the above copyright
|
||||
// notice, this list of conditions and the following disclaimer.
|
||||
//
|
||||
// 2. Redistributions in binary form must reproduce the above copyright
|
||||
// notice, this list of conditions and the following disclaimer in the
|
||||
// documentation and/or other materials provided with the distribution.
|
||||
//
|
||||
// 3. Neither the name of the copyright holder nor the names of its
|
||||
// contributors may be used to endorse or promote products derived from
|
||||
// this software without specific prior written permission.
|
||||
//
|
||||
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
||||
// FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
// COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
// INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
||||
// BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
// LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
// LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
// ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
// POSSIBILITY OF SUCH DAMAGE.
|
||||
//
|
||||
// ************************************************************************
|
||||
|
||||
#ifndef _preprocessor_Directives_
|
||||
#define _preprocessor_Directives_
|
||||
|
||||
//I/O
|
||||
#include <iostream>
|
||||
#include <fstream>
|
||||
#include <sstream>
|
||||
#include <iomanip>
|
||||
|
||||
//System/C
|
||||
#include <limits>
|
||||
#include <stdexcept> //Exception Handling
|
||||
#include <sys/times.h>
|
||||
#include <unistd.h>
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
|
||||
|
||||
#include <float.h> //Defines the LDBL_MAX and LDBL_MIN in gcc
|
||||
#include <cmath>
|
||||
#include <math.h>
|
||||
#include <ctime>
|
||||
#include <climits>
|
||||
|
||||
//STL
|
||||
#include <vector>
|
||||
#include <string>
|
||||
#include <deque>
|
||||
#include <map>
|
||||
|
||||
//MPI:
|
||||
#include "mpi.h"
|
||||
|
||||
|
||||
|
||||
#endif
|
||||
Loading…
Reference in New Issue