mirror of
https://github.com/sfilippone/amg4psblas.git
synced 2026-10-06 22:55:12 +00:00
Compare commits
22
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 Salvatore Filippone
|
78a4f30951 | ||
 Cirdans-Home
|
68007052d5 | ||
|
Cirdans-Home
|
086d93dd28 | ||
|
Salvatore Filippone
|
be0db4ebdf | ||
|
Salvatore Filippone
|
9b5c3cd23b | ||
|
Salvatore Filippone
|
e3ad1a8516 | ||
|
Salvatore Filippone
|
577b1886d5 | ||
|
Salvatore Filippone
|
534ca2043d | ||
|
Salvatore Filippone
|
f9cfc551c3 | ||
|
Salvatore Filippone
|
a9d444caf6 | ||
|
Salvatore Filippone
|
295a5cccf3 | ||
|
Salvatore Filippone
|
dab8aa9fa1 | ||
|
Salvatore Filippone
|
788211c794 | ||
|
Salvatore Filippone
|
d14bd31b4a | ||
|
Salvatore Filippone
|
11d8c090c8 | ||
|
Salvatore Filippone
|
e500a8a5b5 | ||
|
Salvatore Filippone
|
9e3eb0fdeb | ||
|
Salvatore Filippone
|
3a0c5428d6 | ||
|
Salvatore Filippone
|
0ebf9f1d1c | ||
|
Salvatore Filippone
|
c394470160 | ||
|
Salvatore Filippone
|
2d51afb3c1 | ||
|
Salvatore Filippone
|
07fe952426 |
@@ -408,8 +408,28 @@ module amg_base_prec_type
|
||||
module procedure amg_d_equal_aggregation, amg_s_equal_aggregation
|
||||
end interface amg_equal_aggregation
|
||||
|
||||
!
|
||||
! default to no remapping.
|
||||
! Will need a more sophisticated strategy.
|
||||
!
|
||||
logical, private, save :: do_remap=.false.
|
||||
|
||||
contains
|
||||
|
||||
function amg_get_do_remap() result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
|
||||
res = do_remap
|
||||
end function amg_get_do_remap
|
||||
|
||||
subroutine amg_set_do_remap(val)
|
||||
implicit none
|
||||
logical, intent(in) :: val
|
||||
|
||||
do_remap = val
|
||||
end subroutine amg_set_do_remap
|
||||
|
||||
!
|
||||
! Function: amg_stringval
|
||||
!
|
||||
|
||||
+156
-19
@@ -152,6 +152,15 @@ module amg_c_onelev_mod
|
||||
end type amg_cmlprec_wrk_type
|
||||
private :: c_wrk_alloc, c_wrk_free, &
|
||||
& c_wrk_clone, c_wrk_move_alloc, c_wrk_cnv, c_wrk_sizeof
|
||||
|
||||
type amg_c_remap_data_type
|
||||
type(psb_cspmat_type) :: ac_pre_remap
|
||||
type(psb_desc_type) :: desc_ac_pre_remap
|
||||
integer(psb_ipk_) :: idest
|
||||
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
|
||||
contains
|
||||
procedure, pass(rmp) :: clone => c_remap_data_clone
|
||||
end type amg_c_remap_data_type
|
||||
|
||||
type amg_c_onelev_type
|
||||
class(amg_c_base_smoother_type), allocatable :: sm, sm2a
|
||||
@@ -166,7 +175,8 @@ module amg_c_onelev_mod
|
||||
type(psb_cspmat_type), pointer :: base_a => null()
|
||||
type(psb_desc_type), pointer :: base_desc => null()
|
||||
type(psb_lcspmat_type) :: tprol
|
||||
type(psb_clinmap_type) :: map
|
||||
type(psb_clinmap_type) :: linmap
|
||||
type(amg_c_remap_data_type) :: remap_data
|
||||
real(psb_spk_) :: szratio
|
||||
contains
|
||||
procedure, pass(lv) :: bld_tprol => c_base_onelev_bld_tprol
|
||||
@@ -196,6 +206,13 @@ module amg_c_onelev_mod
|
||||
procedure, nopass :: stringval => amg_stringval
|
||||
procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc
|
||||
|
||||
|
||||
procedure, pass(lv) :: map_rstr_a => amg_c_base_onelev_map_rstr_a
|
||||
procedure, pass(lv) :: map_prol_a => amg_c_base_onelev_map_prol_a
|
||||
procedure, pass(lv) :: map_rstr_v => amg_c_base_onelev_map_rstr_v
|
||||
procedure, pass(lv) :: map_prol_v => amg_c_base_onelev_map_prol_v
|
||||
generic, public :: map_rstr => map_rstr_a, map_rstr_v
|
||||
generic, public :: map_prol => map_prol_a, map_prol_v
|
||||
end type amg_c_onelev_type
|
||||
|
||||
type amg_c_onelev_node
|
||||
@@ -394,6 +411,53 @@ interface
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
end subroutine amg_c_base_onelev_dump
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
complex(psb_spk_), intent(inout) :: u(:)
|
||||
complex(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
end subroutine amg_c_base_onelev_map_rstr_a
|
||||
subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_c_base_onelev_map_rstr_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
complex(psb_spk_), intent(inout) :: u(:)
|
||||
complex(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
|
||||
end subroutine amg_c_base_onelev_map_prol_a
|
||||
subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_c_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
contains
|
||||
!
|
||||
@@ -423,7 +487,7 @@ contains
|
||||
val = val + lv%desc_ac%sizeof()
|
||||
val = val + lv%ac%sizeof()
|
||||
val = val + lv%tprol%sizeof()
|
||||
val = val + lv%map%sizeof()
|
||||
val = val + lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
|
||||
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
|
||||
@@ -553,7 +617,8 @@ contains
|
||||
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
|
||||
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
|
||||
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
|
||||
if (info == psb_success_) call lv%map%clone(lvout%map,info)
|
||||
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
|
||||
lvout%base_a => lv%base_a
|
||||
lvout%base_desc => lv%base_desc
|
||||
|
||||
@@ -584,7 +649,7 @@ contains
|
||||
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
@@ -639,7 +704,17 @@ contains
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
if (info == 0) then
|
||||
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Need to fix this, we need two different allocations
|
||||
!
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
|
||||
& desc2=lv%remap_data%desc_ac_pre_remap)
|
||||
else
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine c_base_onelev_allocate_wrk
|
||||
|
||||
@@ -659,7 +734,7 @@ contains
|
||||
end if
|
||||
end subroutine c_base_onelev_free_wrk
|
||||
|
||||
subroutine c_wrk_alloc(wk,nwv,desc,info,vmold)
|
||||
subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
@@ -670,25 +745,67 @@ contains
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
type(psb_desc_type), intent(in), optional :: desc2
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
call wk%free(info)
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
if (present(desc2)) then
|
||||
!!$ write(0,*) 'Check on wrk_alloc 2',&
|
||||
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
|
||||
!!$ & desc2%get_local_cols(),desc%get_local_cols()
|
||||
!!$ flush(0)
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call psb_geasb(wk%vx2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
end subroutine c_wrk_alloc
|
||||
|
||||
subroutine c_wrk_free(wk,info)
|
||||
@@ -821,4 +938,24 @@ contains
|
||||
end if
|
||||
end function c_wrk_sizeof
|
||||
|
||||
subroutine c_remap_data_clone(rmp, remap_out, info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_c_remap_data_type), target, intent(inout) :: rmp
|
||||
class(amg_c_remap_data_type), target, intent(inout) :: remap_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
|
||||
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
|
||||
end subroutine c_remap_data_clone
|
||||
|
||||
end module amg_c_onelev_mod
|
||||
|
||||
@@ -738,16 +738,15 @@ contains
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np, iproc_
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
icontxt = prec%ctxt
|
||||
call psb_info(icontxt,iam,np)
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,iam,np)
|
||||
iln = size(prec%precv)
|
||||
if (present(istart)) then
|
||||
il1 = max(1,istart)
|
||||
@@ -812,13 +811,13 @@ contains
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local vars
|
||||
integer(psb_ipk_) :: i, j, ln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
|
||||
info = psb_success_
|
||||
select type(pout => precout)
|
||||
class is (amg_cprec_type)
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ag_data = prec%ag_data
|
||||
pout%outer_sweeps = prec%outer_sweeps
|
||||
if (allocated(prec%precv)) then
|
||||
@@ -834,8 +833,8 @@ contains
|
||||
if (info == psb_success_) then
|
||||
pout%precv(lev)%base_a => pout%precv(lev)%ac
|
||||
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
|
||||
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
|
||||
end if
|
||||
end do
|
||||
end if
|
||||
@@ -875,8 +874,8 @@ contains
|
||||
do i=2, size(b%precv)
|
||||
b%precv(i)%base_a => b%precv(i)%ac
|
||||
b%precv(i)%base_desc => b%precv(i)%desc_ac
|
||||
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
|
||||
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
|
||||
end do
|
||||
|
||||
else
|
||||
|
||||
@@ -0,0 +1,590 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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 MLD2P4 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 MLD2P4 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_c_rkr_solver_mod.f90
|
||||
!
|
||||
! Module: amg_c_rkr_solver_mod
|
||||
!
|
||||
module amg_c_rkr_solver
|
||||
|
||||
use amg_c_base_solver_mod
|
||||
use amg_c_prec_type
|
||||
|
||||
type, extends(amg_c_base_solver_type) :: amg_c_rkr_solver_type
|
||||
!
|
||||
logical :: global
|
||||
character(len=16) :: method, kprec, sub_solve
|
||||
integer(psb_ipk_) :: irst, istopc, itmax, itrace, i_sub_solve
|
||||
integer(psb_ipk_) :: fillin
|
||||
real(psb_spk_) :: eps
|
||||
type(amg_cprec_type) :: prec
|
||||
type(psb_desc_type) :: desc_local
|
||||
type(psb_cspmat_type) :: a_local
|
||||
type(psb_c_vect_type) :: x_local, z_local
|
||||
type(psb_cspmat_type), pointer :: a=>null()
|
||||
contains
|
||||
!
|
||||
!
|
||||
procedure, pass(sv) :: dump => c_rkr_solver_dmp
|
||||
procedure, pass(sv) :: check => c_rkr_solver_check
|
||||
procedure, pass(sv) :: clone => c_rkr_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => c_rkr_solver_clone_settings
|
||||
procedure, pass(sv) :: cnv => c_rkr_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_c_rkr_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_c_rkr_solver_apply
|
||||
procedure, pass(sv) :: clear_data => c_rkr_solver_clear_data
|
||||
procedure, pass(sv) :: free => c_rkr_solver_free
|
||||
procedure, pass(sv) :: cseti => c_rkr_solver_cseti
|
||||
procedure, pass(sv) :: csetc => c_rkr_solver_csetc
|
||||
procedure, pass(sv) :: csetr => c_rkr_solver_csetr
|
||||
procedure, pass(sv) :: sizeof => c_rkr_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => c_rkr_solver_get_nzeros
|
||||
!procedure, nopass :: get_id => c_rkr_solver_get_id
|
||||
procedure, pass(sv) :: is_global => c_rkr_solver_is_global
|
||||
procedure, nopass :: is_iterative => c_rkr_solver_is_iterative
|
||||
|
||||
|
||||
!
|
||||
! These methods are specific for the new solver type
|
||||
! and therefore need to be overridden
|
||||
!
|
||||
procedure, pass(sv) :: descr => c_rkr_solver_descr
|
||||
procedure, pass(sv) :: default => c_rkr_solver_default
|
||||
procedure, pass(sv) :: build => amg_c_rkr_solver_bld
|
||||
procedure, nopass :: get_fmt => c_rkr_solver_get_fmt
|
||||
end type amg_c_rkr_solver_type
|
||||
|
||||
|
||||
private :: c_rkr_solver_get_fmt, c_rkr_solver_descr, c_rkr_solver_default
|
||||
|
||||
interface
|
||||
subroutine amg_c_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_c_rkr_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_c_vect_type),intent(inout) :: x
|
||||
type(psb_c_vect_type),intent(inout) :: y
|
||||
complex(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_c_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_c_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_c_rkr_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_c_rkr_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
complex(psb_spk_),intent(inout) :: x(:)
|
||||
complex(psb_spk_),intent(inout) :: y(:)
|
||||
complex(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_spk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
complex(psb_spk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_c_rkr_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_c_rkr_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_cspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_cspmat_type), intent(in), target, optional :: b
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_c_rkr_solver_bld
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
!
|
||||
!
|
||||
subroutine c_rkr_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%method = 'bicgstab'
|
||||
sv%kprec = 'bjac'
|
||||
sv%sub_solve = 'ilu'
|
||||
sv%i_sub_solve = -1
|
||||
sv%fillin = 1
|
||||
sv%irst = 30
|
||||
sv%istopc = 2
|
||||
sv%itmax = 40
|
||||
sv%itrace = -1
|
||||
sv%eps = 1.d-6
|
||||
sv%global = .false.
|
||||
|
||||
return
|
||||
end subroutine c_rkr_solver_default
|
||||
|
||||
function c_rkr_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%get_nzeros()
|
||||
|
||||
return
|
||||
end function c_rkr_solver_get_nzeros
|
||||
|
||||
function c_rkr_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%sizeof() + sv%desc_local%sizeof() + sv%a_local%sizeof()
|
||||
|
||||
return
|
||||
end function c_rkr_solver_sizeof
|
||||
|
||||
|
||||
subroutine c_rkr_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_rkr_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine c_rkr_solver_check
|
||||
|
||||
subroutine c_rkr_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
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
|
||||
character(len=20) :: name='c_rkr_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_IRST')
|
||||
sv%irst = val
|
||||
case('RKR_ISTOPC')
|
||||
sv%istopc = val
|
||||
case('RKR_ITMAX')
|
||||
sv%itmax = val
|
||||
case('RKR_ITRACE')
|
||||
sv%itrace = val
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%i_sub_solve = val
|
||||
case('RKR_FILLIN')
|
||||
sv%fillin = val
|
||||
case default
|
||||
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_rkr_solver_cseti
|
||||
|
||||
subroutine c_rkr_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
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, ival
|
||||
character(len=20) :: name='c_rkr_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_METHOD')
|
||||
sv%method = psb_toupper(trim(val))
|
||||
case('RKR_KPREC')
|
||||
sv%kprec = psb_toupper(trim(val))
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%sub_solve = psb_toupper(trim(val))
|
||||
case('RKR_GLOBAL')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('LOCAL','FALSE')
|
||||
sv%global = .false.
|
||||
case('GLOBAL','TRUE')
|
||||
sv%global =.true.
|
||||
end select
|
||||
case default
|
||||
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
call psb_errpush(info, name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_rkr_solver_csetc
|
||||
|
||||
subroutine c_rkr_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_rkr_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('RKR_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_rkr_solver_csetr
|
||||
|
||||
subroutine c_rkr_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='c_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%prec%free(info)
|
||||
call sv%a_local%free()
|
||||
call sv%x_local%free(info)
|
||||
call sv%z_local%free(info)
|
||||
if ((.not.sv%global).and.sv%desc_local%is_ok()) then
|
||||
l_ctxt=sv%desc_local%get_context()
|
||||
call psb_exit(l_ctxt,close=.false.)
|
||||
end if
|
||||
call sv%desc_local%free(info)
|
||||
nullify(sv%a)
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine c_rkr_solver_clear_data
|
||||
|
||||
|
||||
subroutine c_rkr_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='c_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%clear_data(info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine c_rkr_solver_free
|
||||
|
||||
function c_rkr_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "RKR solver"
|
||||
end function c_rkr_solver_get_fmt
|
||||
|
||||
subroutine c_rkr_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_c_rkr_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
if (sv%global) then
|
||||
write(iout_,*) ' Recursive Krylov solver (global)'
|
||||
else
|
||||
write(iout_,*) ' Recursive Krylov solver (local) '
|
||||
end if
|
||||
write(iout_,*) ' method: ',sv%method
|
||||
write(iout_,*) ' kprec: ',sv%kprec
|
||||
if (sv%i_sub_solve > 0) then
|
||||
write(iout_,*) ' sub_solve: ',amg_fact_names(sv%i_sub_solve)
|
||||
else
|
||||
write(iout_,*) ' sub_solve: ',sv%sub_solve
|
||||
end if
|
||||
write(iout_,*) ' itmax: ',sv%itmax
|
||||
write(iout_,*) ' eps: ',sv%eps
|
||||
write(iout_,*) ' fillin: ',sv%fillin
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_rkr_solver_descr
|
||||
|
||||
subroutine c_rkr_solver_cnv(sv,info,amold,vmold,imold)
|
||||
implicit none
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call sv%prec%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
end subroutine c_rkr_solver_cnv
|
||||
|
||||
subroutine c_rkr_solver_clone(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call svout%free(info)
|
||||
allocate(svout,stat=info,mold=sv)
|
||||
select type(so=>svout)
|
||||
class is(amg_c_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
call sv%a_local%clone(so%a_local,info)
|
||||
call sv%desc_local%clone(so%desc_local,info)
|
||||
call sv%prec%clone(so%prec,info)
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine c_rkr_solver_clone
|
||||
|
||||
|
||||
subroutine c_rkr_solver_clone_settings(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_c_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(so=>svout)
|
||||
class is(amg_c_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine c_rkr_solver_clone_settings
|
||||
|
||||
subroutine c_rkr_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
implicit none
|
||||
class(amg_c_rkr_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
|
||||
|
||||
call sv%prec%dump(info,prefix=prefix,head=head)
|
||||
|
||||
end subroutine c_rkr_solver_dmp
|
||||
!
|
||||
! Notify whether RKR is used as a global solver
|
||||
!
|
||||
function c_rkr_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(amg_c_rkr_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%global)
|
||||
end function c_rkr_solver_is_global
|
||||
!
|
||||
function c_rkr_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function c_rkr_solver_is_iterative
|
||||
|
||||
end module amg_c_rkr_solver
|
||||
+156
-19
@@ -152,6 +152,15 @@ module amg_d_onelev_mod
|
||||
end type amg_dmlprec_wrk_type
|
||||
private :: d_wrk_alloc, d_wrk_free, &
|
||||
& d_wrk_clone, d_wrk_move_alloc, d_wrk_cnv, d_wrk_sizeof
|
||||
|
||||
type amg_d_remap_data_type
|
||||
type(psb_dspmat_type) :: ac_pre_remap
|
||||
type(psb_desc_type) :: desc_ac_pre_remap
|
||||
integer(psb_ipk_) :: idest
|
||||
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
|
||||
contains
|
||||
procedure, pass(rmp) :: clone => d_remap_data_clone
|
||||
end type amg_d_remap_data_type
|
||||
|
||||
type amg_d_onelev_type
|
||||
class(amg_d_base_smoother_type), allocatable :: sm, sm2a
|
||||
@@ -166,7 +175,8 @@ module amg_d_onelev_mod
|
||||
type(psb_dspmat_type), pointer :: base_a => null()
|
||||
type(psb_desc_type), pointer :: base_desc => null()
|
||||
type(psb_ldspmat_type) :: tprol
|
||||
type(psb_dlinmap_type) :: map
|
||||
type(psb_dlinmap_type) :: linmap
|
||||
type(amg_d_remap_data_type) :: remap_data
|
||||
real(psb_dpk_) :: szratio
|
||||
contains
|
||||
procedure, pass(lv) :: bld_tprol => d_base_onelev_bld_tprol
|
||||
@@ -196,6 +206,13 @@ module amg_d_onelev_mod
|
||||
procedure, nopass :: stringval => amg_stringval
|
||||
procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc
|
||||
|
||||
|
||||
procedure, pass(lv) :: map_rstr_a => amg_d_base_onelev_map_rstr_a
|
||||
procedure, pass(lv) :: map_prol_a => amg_d_base_onelev_map_prol_a
|
||||
procedure, pass(lv) :: map_rstr_v => amg_d_base_onelev_map_rstr_v
|
||||
procedure, pass(lv) :: map_prol_v => amg_d_base_onelev_map_prol_v
|
||||
generic, public :: map_rstr => map_rstr_a, map_rstr_v
|
||||
generic, public :: map_prol => map_prol_a, map_prol_v
|
||||
end type amg_d_onelev_type
|
||||
|
||||
type amg_d_onelev_node
|
||||
@@ -394,6 +411,53 @@ interface
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
end subroutine amg_d_base_onelev_dump
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
real(psb_dpk_), intent(inout) :: u(:)
|
||||
real(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
end subroutine amg_d_base_onelev_map_rstr_a
|
||||
subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_d_base_onelev_map_rstr_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
real(psb_dpk_), intent(inout) :: u(:)
|
||||
real(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
|
||||
end subroutine amg_d_base_onelev_map_prol_a
|
||||
subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_d_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
contains
|
||||
!
|
||||
@@ -423,7 +487,7 @@ contains
|
||||
val = val + lv%desc_ac%sizeof()
|
||||
val = val + lv%ac%sizeof()
|
||||
val = val + lv%tprol%sizeof()
|
||||
val = val + lv%map%sizeof()
|
||||
val = val + lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
|
||||
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
|
||||
@@ -553,7 +617,8 @@ contains
|
||||
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
|
||||
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
|
||||
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
|
||||
if (info == psb_success_) call lv%map%clone(lvout%map,info)
|
||||
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
|
||||
lvout%base_a => lv%base_a
|
||||
lvout%base_desc => lv%base_desc
|
||||
|
||||
@@ -584,7 +649,7 @@ contains
|
||||
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
@@ -639,7 +704,17 @@ contains
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
if (info == 0) then
|
||||
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Need to fix this, we need two different allocations
|
||||
!
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
|
||||
& desc2=lv%remap_data%desc_ac_pre_remap)
|
||||
else
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine d_base_onelev_allocate_wrk
|
||||
|
||||
@@ -659,7 +734,7 @@ contains
|
||||
end if
|
||||
end subroutine d_base_onelev_free_wrk
|
||||
|
||||
subroutine d_wrk_alloc(wk,nwv,desc,info,vmold)
|
||||
subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
@@ -670,25 +745,67 @@ contains
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
type(psb_desc_type), intent(in), optional :: desc2
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
call wk%free(info)
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
if (present(desc2)) then
|
||||
!!$ write(0,*) 'Check on wrk_alloc 2',&
|
||||
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
|
||||
!!$ & desc2%get_local_cols(),desc%get_local_cols()
|
||||
!!$ flush(0)
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call psb_geasb(wk%vx2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
end subroutine d_wrk_alloc
|
||||
|
||||
subroutine d_wrk_free(wk,info)
|
||||
@@ -821,4 +938,24 @@ contains
|
||||
end if
|
||||
end function d_wrk_sizeof
|
||||
|
||||
subroutine d_remap_data_clone(rmp, remap_out, info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_d_remap_data_type), target, intent(inout) :: rmp
|
||||
class(amg_d_remap_data_type), target, intent(inout) :: remap_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
|
||||
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
|
||||
end subroutine d_remap_data_clone
|
||||
|
||||
end module amg_d_onelev_mod
|
||||
|
||||
@@ -738,16 +738,15 @@ contains
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np, iproc_
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
icontxt = prec%ctxt
|
||||
call psb_info(icontxt,iam,np)
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,iam,np)
|
||||
iln = size(prec%precv)
|
||||
if (present(istart)) then
|
||||
il1 = max(1,istart)
|
||||
@@ -812,13 +811,13 @@ contains
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local vars
|
||||
integer(psb_ipk_) :: i, j, ln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
|
||||
info = psb_success_
|
||||
select type(pout => precout)
|
||||
class is (amg_dprec_type)
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ag_data = prec%ag_data
|
||||
pout%outer_sweeps = prec%outer_sweeps
|
||||
if (allocated(prec%precv)) then
|
||||
@@ -834,8 +833,8 @@ contains
|
||||
if (info == psb_success_) then
|
||||
pout%precv(lev)%base_a => pout%precv(lev)%ac
|
||||
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
|
||||
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
|
||||
end if
|
||||
end do
|
||||
end if
|
||||
@@ -875,8 +874,8 @@ contains
|
||||
do i=2, size(b%precv)
|
||||
b%precv(i)%base_a => b%precv(i)%ac
|
||||
b%precv(i)%base_desc => b%precv(i)%desc_ac
|
||||
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
|
||||
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
|
||||
end do
|
||||
|
||||
else
|
||||
|
||||
@@ -0,0 +1,590 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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 MLD2P4 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 MLD2P4 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_rkr_solver_mod.f90
|
||||
!
|
||||
! Module: amg_d_rkr_solver_mod
|
||||
!
|
||||
module amg_d_rkr_solver
|
||||
|
||||
use amg_d_base_solver_mod
|
||||
use amg_d_prec_type
|
||||
|
||||
type, extends(amg_d_base_solver_type) :: amg_d_rkr_solver_type
|
||||
!
|
||||
logical :: global
|
||||
character(len=16) :: method, kprec, sub_solve
|
||||
integer(psb_ipk_) :: irst, istopc, itmax, itrace, i_sub_solve
|
||||
integer(psb_ipk_) :: fillin
|
||||
real(psb_dpk_) :: eps
|
||||
type(amg_dprec_type) :: prec
|
||||
type(psb_desc_type) :: desc_local
|
||||
type(psb_dspmat_type) :: a_local
|
||||
type(psb_d_vect_type) :: x_local, z_local
|
||||
type(psb_dspmat_type), pointer :: a=>null()
|
||||
contains
|
||||
!
|
||||
!
|
||||
procedure, pass(sv) :: dump => d_rkr_solver_dmp
|
||||
procedure, pass(sv) :: check => d_rkr_solver_check
|
||||
procedure, pass(sv) :: clone => d_rkr_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => d_rkr_solver_clone_settings
|
||||
procedure, pass(sv) :: cnv => d_rkr_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_d_rkr_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_d_rkr_solver_apply
|
||||
procedure, pass(sv) :: clear_data => d_rkr_solver_clear_data
|
||||
procedure, pass(sv) :: free => d_rkr_solver_free
|
||||
procedure, pass(sv) :: cseti => d_rkr_solver_cseti
|
||||
procedure, pass(sv) :: csetc => d_rkr_solver_csetc
|
||||
procedure, pass(sv) :: csetr => d_rkr_solver_csetr
|
||||
procedure, pass(sv) :: sizeof => d_rkr_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => d_rkr_solver_get_nzeros
|
||||
!procedure, nopass :: get_id => d_rkr_solver_get_id
|
||||
procedure, pass(sv) :: is_global => d_rkr_solver_is_global
|
||||
procedure, nopass :: is_iterative => d_rkr_solver_is_iterative
|
||||
|
||||
|
||||
!
|
||||
! These methods are specific for the new solver type
|
||||
! and therefore need to be overridden
|
||||
!
|
||||
procedure, pass(sv) :: descr => d_rkr_solver_descr
|
||||
procedure, pass(sv) :: default => d_rkr_solver_default
|
||||
procedure, pass(sv) :: build => amg_d_rkr_solver_bld
|
||||
procedure, nopass :: get_fmt => d_rkr_solver_get_fmt
|
||||
end type amg_d_rkr_solver_type
|
||||
|
||||
|
||||
private :: d_rkr_solver_get_fmt, d_rkr_solver_descr, d_rkr_solver_default
|
||||
|
||||
interface
|
||||
subroutine amg_d_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_d_rkr_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_d_vect_type),intent(inout) :: x
|
||||
type(psb_d_vect_type),intent(inout) :: y
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_d_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_d_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_d_rkr_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_d_rkr_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
real(psb_dpk_),intent(inout) :: x(:)
|
||||
real(psb_dpk_),intent(inout) :: y(:)
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
real(psb_dpk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_d_rkr_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_d_rkr_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_dspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_dspmat_type), intent(in), target, optional :: b
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_d_rkr_solver_bld
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
!
|
||||
!
|
||||
subroutine d_rkr_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%method = 'bicgstab'
|
||||
sv%kprec = 'bjac'
|
||||
sv%sub_solve = 'ilu'
|
||||
sv%i_sub_solve = -1
|
||||
sv%fillin = 1
|
||||
sv%irst = 30
|
||||
sv%istopc = 2
|
||||
sv%itmax = 40
|
||||
sv%itrace = -1
|
||||
sv%eps = 1.d-6
|
||||
sv%global = .false.
|
||||
|
||||
return
|
||||
end subroutine d_rkr_solver_default
|
||||
|
||||
function d_rkr_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%get_nzeros()
|
||||
|
||||
return
|
||||
end function d_rkr_solver_get_nzeros
|
||||
|
||||
function d_rkr_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%sizeof() + sv%desc_local%sizeof() + sv%a_local%sizeof()
|
||||
|
||||
return
|
||||
end function d_rkr_solver_sizeof
|
||||
|
||||
|
||||
subroutine d_rkr_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_rkr_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine d_rkr_solver_check
|
||||
|
||||
subroutine d_rkr_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
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
|
||||
character(len=20) :: name='d_rkr_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_IRST')
|
||||
sv%irst = val
|
||||
case('RKR_ISTOPC')
|
||||
sv%istopc = val
|
||||
case('RKR_ITMAX')
|
||||
sv%itmax = val
|
||||
case('RKR_ITRACE')
|
||||
sv%itrace = val
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%i_sub_solve = val
|
||||
case('RKR_FILLIN')
|
||||
sv%fillin = val
|
||||
case default
|
||||
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_rkr_solver_cseti
|
||||
|
||||
subroutine d_rkr_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
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, ival
|
||||
character(len=20) :: name='d_rkr_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_METHOD')
|
||||
sv%method = psb_toupper(trim(val))
|
||||
case('RKR_KPREC')
|
||||
sv%kprec = psb_toupper(trim(val))
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%sub_solve = psb_toupper(trim(val))
|
||||
case('RKR_GLOBAL')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('LOCAL','FALSE')
|
||||
sv%global = .false.
|
||||
case('GLOBAL','TRUE')
|
||||
sv%global =.true.
|
||||
end select
|
||||
case default
|
||||
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
call psb_errpush(info, name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_rkr_solver_csetc
|
||||
|
||||
subroutine d_rkr_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_rkr_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('RKR_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_rkr_solver_csetr
|
||||
|
||||
subroutine d_rkr_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='d_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%prec%free(info)
|
||||
call sv%a_local%free()
|
||||
call sv%x_local%free(info)
|
||||
call sv%z_local%free(info)
|
||||
if ((.not.sv%global).and.sv%desc_local%is_ok()) then
|
||||
l_ctxt=sv%desc_local%get_context()
|
||||
call psb_exit(l_ctxt,close=.false.)
|
||||
end if
|
||||
call sv%desc_local%free(info)
|
||||
nullify(sv%a)
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine d_rkr_solver_clear_data
|
||||
|
||||
|
||||
subroutine d_rkr_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='d_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%clear_data(info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine d_rkr_solver_free
|
||||
|
||||
function d_rkr_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "RKR solver"
|
||||
end function d_rkr_solver_get_fmt
|
||||
|
||||
subroutine d_rkr_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_d_rkr_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
if (sv%global) then
|
||||
write(iout_,*) ' Recursive Krylov solver (global)'
|
||||
else
|
||||
write(iout_,*) ' Recursive Krylov solver (local) '
|
||||
end if
|
||||
write(iout_,*) ' method: ',sv%method
|
||||
write(iout_,*) ' kprec: ',sv%kprec
|
||||
if (sv%i_sub_solve > 0) then
|
||||
write(iout_,*) ' sub_solve: ',amg_fact_names(sv%i_sub_solve)
|
||||
else
|
||||
write(iout_,*) ' sub_solve: ',sv%sub_solve
|
||||
end if
|
||||
write(iout_,*) ' itmax: ',sv%itmax
|
||||
write(iout_,*) ' eps: ',sv%eps
|
||||
write(iout_,*) ' fillin: ',sv%fillin
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_rkr_solver_descr
|
||||
|
||||
subroutine d_rkr_solver_cnv(sv,info,amold,vmold,imold)
|
||||
implicit none
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call sv%prec%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
end subroutine d_rkr_solver_cnv
|
||||
|
||||
subroutine d_rkr_solver_clone(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call svout%free(info)
|
||||
allocate(svout,stat=info,mold=sv)
|
||||
select type(so=>svout)
|
||||
class is(amg_d_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
call sv%a_local%clone(so%a_local,info)
|
||||
call sv%desc_local%clone(so%desc_local,info)
|
||||
call sv%prec%clone(so%prec,info)
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine d_rkr_solver_clone
|
||||
|
||||
|
||||
subroutine d_rkr_solver_clone_settings(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_d_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(so=>svout)
|
||||
class is(amg_d_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine d_rkr_solver_clone_settings
|
||||
|
||||
subroutine d_rkr_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
implicit none
|
||||
class(amg_d_rkr_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
|
||||
|
||||
call sv%prec%dump(info,prefix=prefix,head=head)
|
||||
|
||||
end subroutine d_rkr_solver_dmp
|
||||
!
|
||||
! Notify whether RKR is used as a global solver
|
||||
!
|
||||
function d_rkr_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(amg_d_rkr_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%global)
|
||||
end function d_rkr_solver_is_global
|
||||
!
|
||||
function d_rkr_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function d_rkr_solver_is_iterative
|
||||
|
||||
end module amg_d_rkr_solver
|
||||
+156
-19
@@ -152,6 +152,15 @@ module amg_s_onelev_mod
|
||||
end type amg_smlprec_wrk_type
|
||||
private :: s_wrk_alloc, s_wrk_free, &
|
||||
& s_wrk_clone, s_wrk_move_alloc, s_wrk_cnv, s_wrk_sizeof
|
||||
|
||||
type amg_s_remap_data_type
|
||||
type(psb_sspmat_type) :: ac_pre_remap
|
||||
type(psb_desc_type) :: desc_ac_pre_remap
|
||||
integer(psb_ipk_) :: idest
|
||||
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
|
||||
contains
|
||||
procedure, pass(rmp) :: clone => s_remap_data_clone
|
||||
end type amg_s_remap_data_type
|
||||
|
||||
type amg_s_onelev_type
|
||||
class(amg_s_base_smoother_type), allocatable :: sm, sm2a
|
||||
@@ -166,7 +175,8 @@ module amg_s_onelev_mod
|
||||
type(psb_sspmat_type), pointer :: base_a => null()
|
||||
type(psb_desc_type), pointer :: base_desc => null()
|
||||
type(psb_lsspmat_type) :: tprol
|
||||
type(psb_slinmap_type) :: map
|
||||
type(psb_slinmap_type) :: linmap
|
||||
type(amg_s_remap_data_type) :: remap_data
|
||||
real(psb_spk_) :: szratio
|
||||
contains
|
||||
procedure, pass(lv) :: bld_tprol => s_base_onelev_bld_tprol
|
||||
@@ -196,6 +206,13 @@ module amg_s_onelev_mod
|
||||
procedure, nopass :: stringval => amg_stringval
|
||||
procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc
|
||||
|
||||
|
||||
procedure, pass(lv) :: map_rstr_a => amg_s_base_onelev_map_rstr_a
|
||||
procedure, pass(lv) :: map_prol_a => amg_s_base_onelev_map_prol_a
|
||||
procedure, pass(lv) :: map_rstr_v => amg_s_base_onelev_map_rstr_v
|
||||
procedure, pass(lv) :: map_prol_v => amg_s_base_onelev_map_prol_v
|
||||
generic, public :: map_rstr => map_rstr_a, map_rstr_v
|
||||
generic, public :: map_prol => map_prol_a, map_prol_v
|
||||
end type amg_s_onelev_type
|
||||
|
||||
type amg_s_onelev_node
|
||||
@@ -394,6 +411,53 @@ interface
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
end subroutine amg_s_base_onelev_dump
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
real(psb_spk_), intent(inout) :: u(:)
|
||||
real(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
end subroutine amg_s_base_onelev_map_rstr_a
|
||||
subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_s_base_onelev_map_rstr_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
real(psb_spk_), intent(inout) :: u(:)
|
||||
real(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
|
||||
end subroutine amg_s_base_onelev_map_prol_a
|
||||
subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_s_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
contains
|
||||
!
|
||||
@@ -423,7 +487,7 @@ contains
|
||||
val = val + lv%desc_ac%sizeof()
|
||||
val = val + lv%ac%sizeof()
|
||||
val = val + lv%tprol%sizeof()
|
||||
val = val + lv%map%sizeof()
|
||||
val = val + lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
|
||||
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
|
||||
@@ -553,7 +617,8 @@ contains
|
||||
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
|
||||
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
|
||||
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
|
||||
if (info == psb_success_) call lv%map%clone(lvout%map,info)
|
||||
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
|
||||
lvout%base_a => lv%base_a
|
||||
lvout%base_desc => lv%base_desc
|
||||
|
||||
@@ -584,7 +649,7 @@ contains
|
||||
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
@@ -639,7 +704,17 @@ contains
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
if (info == 0) then
|
||||
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Need to fix this, we need two different allocations
|
||||
!
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
|
||||
& desc2=lv%remap_data%desc_ac_pre_remap)
|
||||
else
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine s_base_onelev_allocate_wrk
|
||||
|
||||
@@ -659,7 +734,7 @@ contains
|
||||
end if
|
||||
end subroutine s_base_onelev_free_wrk
|
||||
|
||||
subroutine s_wrk_alloc(wk,nwv,desc,info,vmold)
|
||||
subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
@@ -670,25 +745,67 @@ contains
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
type(psb_desc_type), intent(in), optional :: desc2
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
call wk%free(info)
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
if (present(desc2)) then
|
||||
!!$ write(0,*) 'Check on wrk_alloc 2',&
|
||||
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
|
||||
!!$ & desc2%get_local_cols(),desc%get_local_cols()
|
||||
!!$ flush(0)
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call psb_geasb(wk%vx2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
end subroutine s_wrk_alloc
|
||||
|
||||
subroutine s_wrk_free(wk,info)
|
||||
@@ -821,4 +938,24 @@ contains
|
||||
end if
|
||||
end function s_wrk_sizeof
|
||||
|
||||
subroutine s_remap_data_clone(rmp, remap_out, info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_s_remap_data_type), target, intent(inout) :: rmp
|
||||
class(amg_s_remap_data_type), target, intent(inout) :: remap_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
|
||||
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
|
||||
end subroutine s_remap_data_clone
|
||||
|
||||
end module amg_s_onelev_mod
|
||||
|
||||
@@ -738,16 +738,15 @@ contains
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np, iproc_
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
icontxt = prec%ctxt
|
||||
call psb_info(icontxt,iam,np)
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,iam,np)
|
||||
iln = size(prec%precv)
|
||||
if (present(istart)) then
|
||||
il1 = max(1,istart)
|
||||
@@ -812,13 +811,13 @@ contains
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local vars
|
||||
integer(psb_ipk_) :: i, j, ln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
|
||||
info = psb_success_
|
||||
select type(pout => precout)
|
||||
class is (amg_sprec_type)
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ag_data = prec%ag_data
|
||||
pout%outer_sweeps = prec%outer_sweeps
|
||||
if (allocated(prec%precv)) then
|
||||
@@ -834,8 +833,8 @@ contains
|
||||
if (info == psb_success_) then
|
||||
pout%precv(lev)%base_a => pout%precv(lev)%ac
|
||||
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
|
||||
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
|
||||
end if
|
||||
end do
|
||||
end if
|
||||
@@ -875,8 +874,8 @@ contains
|
||||
do i=2, size(b%precv)
|
||||
b%precv(i)%base_a => b%precv(i)%ac
|
||||
b%precv(i)%base_desc => b%precv(i)%desc_ac
|
||||
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
|
||||
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
|
||||
end do
|
||||
|
||||
else
|
||||
|
||||
@@ -0,0 +1,590 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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 MLD2P4 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 MLD2P4 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_rkr_solver_mod.f90
|
||||
!
|
||||
! Module: amg_s_rkr_solver_mod
|
||||
!
|
||||
module amg_s_rkr_solver
|
||||
|
||||
use amg_s_base_solver_mod
|
||||
use amg_s_prec_type
|
||||
|
||||
type, extends(amg_s_base_solver_type) :: amg_s_rkr_solver_type
|
||||
!
|
||||
logical :: global
|
||||
character(len=16) :: method, kprec, sub_solve
|
||||
integer(psb_ipk_) :: irst, istopc, itmax, itrace, i_sub_solve
|
||||
integer(psb_ipk_) :: fillin
|
||||
real(psb_spk_) :: eps
|
||||
type(amg_sprec_type) :: prec
|
||||
type(psb_desc_type) :: desc_local
|
||||
type(psb_sspmat_type) :: a_local
|
||||
type(psb_s_vect_type) :: x_local, z_local
|
||||
type(psb_sspmat_type), pointer :: a=>null()
|
||||
contains
|
||||
!
|
||||
!
|
||||
procedure, pass(sv) :: dump => s_rkr_solver_dmp
|
||||
procedure, pass(sv) :: check => s_rkr_solver_check
|
||||
procedure, pass(sv) :: clone => s_rkr_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => s_rkr_solver_clone_settings
|
||||
procedure, pass(sv) :: cnv => s_rkr_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_s_rkr_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_s_rkr_solver_apply
|
||||
procedure, pass(sv) :: clear_data => s_rkr_solver_clear_data
|
||||
procedure, pass(sv) :: free => s_rkr_solver_free
|
||||
procedure, pass(sv) :: cseti => s_rkr_solver_cseti
|
||||
procedure, pass(sv) :: csetc => s_rkr_solver_csetc
|
||||
procedure, pass(sv) :: csetr => s_rkr_solver_csetr
|
||||
procedure, pass(sv) :: sizeof => s_rkr_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => s_rkr_solver_get_nzeros
|
||||
!procedure, nopass :: get_id => s_rkr_solver_get_id
|
||||
procedure, pass(sv) :: is_global => s_rkr_solver_is_global
|
||||
procedure, nopass :: is_iterative => s_rkr_solver_is_iterative
|
||||
|
||||
|
||||
!
|
||||
! These methods are specific for the new solver type
|
||||
! and therefore need to be overridden
|
||||
!
|
||||
procedure, pass(sv) :: descr => s_rkr_solver_descr
|
||||
procedure, pass(sv) :: default => s_rkr_solver_default
|
||||
procedure, pass(sv) :: build => amg_s_rkr_solver_bld
|
||||
procedure, nopass :: get_fmt => s_rkr_solver_get_fmt
|
||||
end type amg_s_rkr_solver_type
|
||||
|
||||
|
||||
private :: s_rkr_solver_get_fmt, s_rkr_solver_descr, s_rkr_solver_default
|
||||
|
||||
interface
|
||||
subroutine amg_s_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_s_rkr_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_s_vect_type),intent(inout) :: x
|
||||
type(psb_s_vect_type),intent(inout) :: y
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_s_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_s_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_s_rkr_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_s_rkr_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
real(psb_spk_),intent(inout) :: x(:)
|
||||
real(psb_spk_),intent(inout) :: y(:)
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
real(psb_spk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_s_rkr_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_s_rkr_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_sspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_sspmat_type), intent(in), target, optional :: b
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_s_rkr_solver_bld
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
!
|
||||
!
|
||||
subroutine s_rkr_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%method = 'bicgstab'
|
||||
sv%kprec = 'bjac'
|
||||
sv%sub_solve = 'ilu'
|
||||
sv%i_sub_solve = -1
|
||||
sv%fillin = 1
|
||||
sv%irst = 30
|
||||
sv%istopc = 2
|
||||
sv%itmax = 40
|
||||
sv%itrace = -1
|
||||
sv%eps = 1.d-6
|
||||
sv%global = .false.
|
||||
|
||||
return
|
||||
end subroutine s_rkr_solver_default
|
||||
|
||||
function s_rkr_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%get_nzeros()
|
||||
|
||||
return
|
||||
end function s_rkr_solver_get_nzeros
|
||||
|
||||
function s_rkr_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%sizeof() + sv%desc_local%sizeof() + sv%a_local%sizeof()
|
||||
|
||||
return
|
||||
end function s_rkr_solver_sizeof
|
||||
|
||||
|
||||
subroutine s_rkr_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_rkr_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine s_rkr_solver_check
|
||||
|
||||
subroutine s_rkr_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
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
|
||||
character(len=20) :: name='s_rkr_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_IRST')
|
||||
sv%irst = val
|
||||
case('RKR_ISTOPC')
|
||||
sv%istopc = val
|
||||
case('RKR_ITMAX')
|
||||
sv%itmax = val
|
||||
case('RKR_ITRACE')
|
||||
sv%itrace = val
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%i_sub_solve = val
|
||||
case('RKR_FILLIN')
|
||||
sv%fillin = val
|
||||
case default
|
||||
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_rkr_solver_cseti
|
||||
|
||||
subroutine s_rkr_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
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, ival
|
||||
character(len=20) :: name='s_rkr_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_METHOD')
|
||||
sv%method = psb_toupper(trim(val))
|
||||
case('RKR_KPREC')
|
||||
sv%kprec = psb_toupper(trim(val))
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%sub_solve = psb_toupper(trim(val))
|
||||
case('RKR_GLOBAL')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('LOCAL','FALSE')
|
||||
sv%global = .false.
|
||||
case('GLOBAL','TRUE')
|
||||
sv%global =.true.
|
||||
end select
|
||||
case default
|
||||
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
call psb_errpush(info, name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_rkr_solver_csetc
|
||||
|
||||
subroutine s_rkr_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_rkr_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('RKR_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_rkr_solver_csetr
|
||||
|
||||
subroutine s_rkr_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='s_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%prec%free(info)
|
||||
call sv%a_local%free()
|
||||
call sv%x_local%free(info)
|
||||
call sv%z_local%free(info)
|
||||
if ((.not.sv%global).and.sv%desc_local%is_ok()) then
|
||||
l_ctxt=sv%desc_local%get_context()
|
||||
call psb_exit(l_ctxt,close=.false.)
|
||||
end if
|
||||
call sv%desc_local%free(info)
|
||||
nullify(sv%a)
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine s_rkr_solver_clear_data
|
||||
|
||||
|
||||
subroutine s_rkr_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='s_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%clear_data(info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine s_rkr_solver_free
|
||||
|
||||
function s_rkr_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "RKR solver"
|
||||
end function s_rkr_solver_get_fmt
|
||||
|
||||
subroutine s_rkr_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_s_rkr_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
if (sv%global) then
|
||||
write(iout_,*) ' Recursive Krylov solver (global)'
|
||||
else
|
||||
write(iout_,*) ' Recursive Krylov solver (local) '
|
||||
end if
|
||||
write(iout_,*) ' method: ',sv%method
|
||||
write(iout_,*) ' kprec: ',sv%kprec
|
||||
if (sv%i_sub_solve > 0) then
|
||||
write(iout_,*) ' sub_solve: ',amg_fact_names(sv%i_sub_solve)
|
||||
else
|
||||
write(iout_,*) ' sub_solve: ',sv%sub_solve
|
||||
end if
|
||||
write(iout_,*) ' itmax: ',sv%itmax
|
||||
write(iout_,*) ' eps: ',sv%eps
|
||||
write(iout_,*) ' fillin: ',sv%fillin
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_rkr_solver_descr
|
||||
|
||||
subroutine s_rkr_solver_cnv(sv,info,amold,vmold,imold)
|
||||
implicit none
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call sv%prec%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
end subroutine s_rkr_solver_cnv
|
||||
|
||||
subroutine s_rkr_solver_clone(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call svout%free(info)
|
||||
allocate(svout,stat=info,mold=sv)
|
||||
select type(so=>svout)
|
||||
class is(amg_s_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
call sv%a_local%clone(so%a_local,info)
|
||||
call sv%desc_local%clone(so%desc_local,info)
|
||||
call sv%prec%clone(so%prec,info)
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine s_rkr_solver_clone
|
||||
|
||||
|
||||
subroutine s_rkr_solver_clone_settings(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_s_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(so=>svout)
|
||||
class is(amg_s_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine s_rkr_solver_clone_settings
|
||||
|
||||
subroutine s_rkr_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
implicit none
|
||||
class(amg_s_rkr_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
|
||||
|
||||
call sv%prec%dump(info,prefix=prefix,head=head)
|
||||
|
||||
end subroutine s_rkr_solver_dmp
|
||||
!
|
||||
! Notify whether RKR is used as a global solver
|
||||
!
|
||||
function s_rkr_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(amg_s_rkr_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%global)
|
||||
end function s_rkr_solver_is_global
|
||||
!
|
||||
function s_rkr_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function s_rkr_solver_is_iterative
|
||||
|
||||
end module amg_s_rkr_solver
|
||||
+156
-19
@@ -152,6 +152,15 @@ module amg_z_onelev_mod
|
||||
end type amg_zmlprec_wrk_type
|
||||
private :: z_wrk_alloc, z_wrk_free, &
|
||||
& z_wrk_clone, z_wrk_move_alloc, z_wrk_cnv, z_wrk_sizeof
|
||||
|
||||
type amg_z_remap_data_type
|
||||
type(psb_zspmat_type) :: ac_pre_remap
|
||||
type(psb_desc_type) :: desc_ac_pre_remap
|
||||
integer(psb_ipk_) :: idest
|
||||
integer(psb_ipk_), allocatable :: isrc(:), nrsrc(:), naggr(:)
|
||||
contains
|
||||
procedure, pass(rmp) :: clone => z_remap_data_clone
|
||||
end type amg_z_remap_data_type
|
||||
|
||||
type amg_z_onelev_type
|
||||
class(amg_z_base_smoother_type), allocatable :: sm, sm2a
|
||||
@@ -166,7 +175,8 @@ module amg_z_onelev_mod
|
||||
type(psb_zspmat_type), pointer :: base_a => null()
|
||||
type(psb_desc_type), pointer :: base_desc => null()
|
||||
type(psb_lzspmat_type) :: tprol
|
||||
type(psb_zlinmap_type) :: map
|
||||
type(psb_zlinmap_type) :: linmap
|
||||
type(amg_z_remap_data_type) :: remap_data
|
||||
real(psb_dpk_) :: szratio
|
||||
contains
|
||||
procedure, pass(lv) :: bld_tprol => z_base_onelev_bld_tprol
|
||||
@@ -196,6 +206,13 @@ module amg_z_onelev_mod
|
||||
procedure, nopass :: stringval => amg_stringval
|
||||
procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc
|
||||
|
||||
|
||||
procedure, pass(lv) :: map_rstr_a => amg_z_base_onelev_map_rstr_a
|
||||
procedure, pass(lv) :: map_prol_a => amg_z_base_onelev_map_prol_a
|
||||
procedure, pass(lv) :: map_rstr_v => amg_z_base_onelev_map_rstr_v
|
||||
procedure, pass(lv) :: map_prol_v => amg_z_base_onelev_map_prol_v
|
||||
generic, public :: map_rstr => map_rstr_a, map_rstr_v
|
||||
generic, public :: map_prol => map_prol_a, map_prol_v
|
||||
end type amg_z_onelev_type
|
||||
|
||||
type amg_z_onelev_node
|
||||
@@ -394,6 +411,53 @@ interface
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
end subroutine amg_z_base_onelev_dump
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
complex(psb_dpk_), intent(inout) :: u(:)
|
||||
complex(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
end subroutine amg_z_base_onelev_map_rstr_a
|
||||
subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_z_base_onelev_map_rstr_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
complex(psb_dpk_), intent(inout) :: u(:)
|
||||
complex(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
|
||||
end subroutine amg_z_base_onelev_map_prol_a
|
||||
subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
import
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
end subroutine amg_z_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
contains
|
||||
!
|
||||
@@ -423,7 +487,7 @@ contains
|
||||
val = val + lv%desc_ac%sizeof()
|
||||
val = val + lv%ac%sizeof()
|
||||
val = val + lv%tprol%sizeof()
|
||||
val = val + lv%map%sizeof()
|
||||
val = val + lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) val = val + lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof()
|
||||
if (allocated(lv%aggr)) val = val + lv%aggr%sizeof()
|
||||
@@ -553,7 +617,8 @@ contains
|
||||
if (info == psb_success_) call lv%ac%clone(lvout%ac,info)
|
||||
if (info == psb_success_) call lv%tprol%clone(lvout%tprol,info)
|
||||
if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info)
|
||||
if (info == psb_success_) call lv%map%clone(lvout%map,info)
|
||||
if (info == psb_success_) call lv%linmap%clone(lvout%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%clone(lvout%remap_data,info)
|
||||
lvout%base_a => lv%base_a
|
||||
lvout%base_desc => lv%base_desc
|
||||
|
||||
@@ -584,7 +649,7 @@ contains
|
||||
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
|
||||
if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
@@ -639,7 +704,17 @@ contains
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
if (info == 0) then
|
||||
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Need to fix this, we need two different allocations
|
||||
!
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,&
|
||||
& desc2=lv%remap_data%desc_ac_pre_remap)
|
||||
else
|
||||
call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine z_base_onelev_allocate_wrk
|
||||
|
||||
@@ -659,7 +734,7 @@ contains
|
||||
end if
|
||||
end subroutine z_base_onelev_free_wrk
|
||||
|
||||
subroutine z_wrk_alloc(wk,nwv,desc,info,vmold)
|
||||
subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
@@ -670,25 +745,67 @@ contains
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
type(psb_desc_type), intent(in), optional :: desc2
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
call wk%free(info)
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
if (present(desc2)) then
|
||||
!!$ write(0,*) 'Check on wrk_alloc 2',&
|
||||
!!$ & desc2%get_local_rows(), desc%get_local_rows(),&
|
||||
!!$ & desc2%get_local_cols(),desc%get_local_cols()
|
||||
!!$ flush(0)
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call psb_geasb(wk%vx2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc2,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1.5 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
else
|
||||
!!$ write(0,*) 'Check on wrk_alloc 1 ',&
|
||||
!!$ & desc%get_local_rows(),&
|
||||
!!$ & desc%get_local_cols()
|
||||
call psb_geasb(wk%vx2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
|
||||
call psb_geasb(wk%vy2l,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vtx,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
call psb_geasb(wk%vty,desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end if
|
||||
end subroutine z_wrk_alloc
|
||||
|
||||
subroutine z_wrk_free(wk,info)
|
||||
@@ -821,4 +938,24 @@ contains
|
||||
end if
|
||||
end function z_wrk_sizeof
|
||||
|
||||
subroutine z_remap_data_clone(rmp, remap_out, info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_z_remap_data_type), target, intent(inout) :: rmp
|
||||
class(amg_z_remap_data_type), target, intent(inout) :: remap_out
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info)
|
||||
call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info)
|
||||
end subroutine z_remap_data_clone
|
||||
|
||||
end module amg_z_onelev_mod
|
||||
|
||||
@@ -738,16 +738,15 @@ contains
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver,ac, rp, tprol, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np, iproc_
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
icontxt = prec%ctxt
|
||||
call psb_info(icontxt,iam,np)
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,iam,np)
|
||||
iln = size(prec%precv)
|
||||
if (present(istart)) then
|
||||
il1 = max(1,istart)
|
||||
@@ -812,13 +811,13 @@ contains
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local vars
|
||||
integer(psb_ipk_) :: i, j, ln, lev
|
||||
type(psb_ctxt_type) :: icontxt
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
|
||||
info = psb_success_
|
||||
select type(pout => precout)
|
||||
class is (amg_zprec_type)
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ctxt = prec%ctxt
|
||||
pout%ag_data = prec%ag_data
|
||||
pout%outer_sweeps = prec%outer_sweeps
|
||||
if (allocated(prec%precv)) then
|
||||
@@ -834,8 +833,8 @@ contains
|
||||
if (info == psb_success_) then
|
||||
pout%precv(lev)%base_a => pout%precv(lev)%ac
|
||||
pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac
|
||||
pout%precv(lev)%map%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%map%p_desc_V => pout%precv(lev)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_U => pout%precv(lev-1)%base_desc
|
||||
pout%precv(lev)%linmap%p_desc_V => pout%precv(lev)%base_desc
|
||||
end if
|
||||
end do
|
||||
end if
|
||||
@@ -875,8 +874,8 @@ contains
|
||||
do i=2, size(b%precv)
|
||||
b%precv(i)%base_a => b%precv(i)%ac
|
||||
b%precv(i)%base_desc => b%precv(i)%desc_ac
|
||||
b%precv(i)%map%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%map%p_desc_V => b%precv(i)%base_desc
|
||||
b%precv(i)%linmap%p_desc_U => b%precv(i-1)%base_desc
|
||||
b%precv(i)%linmap%p_desc_V => b%precv(i)%base_desc
|
||||
end do
|
||||
|
||||
else
|
||||
|
||||
@@ -0,0 +1,590 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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 MLD2P4 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 MLD2P4 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_z_rkr_solver_mod.f90
|
||||
!
|
||||
! Module: amg_z_rkr_solver_mod
|
||||
!
|
||||
module amg_z_rkr_solver
|
||||
|
||||
use amg_z_base_solver_mod
|
||||
use amg_z_prec_type
|
||||
|
||||
type, extends(amg_z_base_solver_type) :: amg_z_rkr_solver_type
|
||||
!
|
||||
logical :: global
|
||||
character(len=16) :: method, kprec, sub_solve
|
||||
integer(psb_ipk_) :: irst, istopc, itmax, itrace, i_sub_solve
|
||||
integer(psb_ipk_) :: fillin
|
||||
real(psb_dpk_) :: eps
|
||||
type(amg_zprec_type) :: prec
|
||||
type(psb_desc_type) :: desc_local
|
||||
type(psb_zspmat_type) :: a_local
|
||||
type(psb_z_vect_type) :: x_local, z_local
|
||||
type(psb_zspmat_type), pointer :: a=>null()
|
||||
contains
|
||||
!
|
||||
!
|
||||
procedure, pass(sv) :: dump => z_rkr_solver_dmp
|
||||
procedure, pass(sv) :: check => z_rkr_solver_check
|
||||
procedure, pass(sv) :: clone => z_rkr_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => z_rkr_solver_clone_settings
|
||||
procedure, pass(sv) :: cnv => z_rkr_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_z_rkr_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_z_rkr_solver_apply
|
||||
procedure, pass(sv) :: clear_data => z_rkr_solver_clear_data
|
||||
procedure, pass(sv) :: free => z_rkr_solver_free
|
||||
procedure, pass(sv) :: cseti => z_rkr_solver_cseti
|
||||
procedure, pass(sv) :: csetc => z_rkr_solver_csetc
|
||||
procedure, pass(sv) :: csetr => z_rkr_solver_csetr
|
||||
procedure, pass(sv) :: sizeof => z_rkr_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => z_rkr_solver_get_nzeros
|
||||
!procedure, nopass :: get_id => z_rkr_solver_get_id
|
||||
procedure, pass(sv) :: is_global => z_rkr_solver_is_global
|
||||
procedure, nopass :: is_iterative => z_rkr_solver_is_iterative
|
||||
|
||||
|
||||
!
|
||||
! These methods are specific for the new solver type
|
||||
! and therefore need to be overridden
|
||||
!
|
||||
procedure, pass(sv) :: descr => z_rkr_solver_descr
|
||||
procedure, pass(sv) :: default => z_rkr_solver_default
|
||||
procedure, pass(sv) :: build => amg_z_rkr_solver_bld
|
||||
procedure, nopass :: get_fmt => z_rkr_solver_get_fmt
|
||||
end type amg_z_rkr_solver_type
|
||||
|
||||
|
||||
private :: z_rkr_solver_get_fmt, z_rkr_solver_descr, z_rkr_solver_default
|
||||
|
||||
interface
|
||||
subroutine amg_z_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_z_rkr_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_z_vect_type),intent(inout) :: x
|
||||
type(psb_z_vect_type),intent(inout) :: y
|
||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_z_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_z_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_z_rkr_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_z_rkr_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
complex(psb_dpk_),intent(inout) :: x(:)
|
||||
complex(psb_dpk_),intent(inout) :: y(:)
|
||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_dpk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
complex(psb_dpk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_z_rkr_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_z_rkr_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_zspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_zspmat_type), intent(in), target, optional :: b
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_z_rkr_solver_bld
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
!
|
||||
!
|
||||
subroutine z_rkr_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%method = 'bicgstab'
|
||||
sv%kprec = 'bjac'
|
||||
sv%sub_solve = 'ilu'
|
||||
sv%i_sub_solve = -1
|
||||
sv%fillin = 1
|
||||
sv%irst = 30
|
||||
sv%istopc = 2
|
||||
sv%itmax = 40
|
||||
sv%itrace = -1
|
||||
sv%eps = 1.d-6
|
||||
sv%global = .false.
|
||||
|
||||
return
|
||||
end subroutine z_rkr_solver_default
|
||||
|
||||
function z_rkr_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%get_nzeros()
|
||||
|
||||
return
|
||||
end function z_rkr_solver_get_nzeros
|
||||
|
||||
function z_rkr_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = sv%prec%sizeof() + sv%desc_local%sizeof() + sv%a_local%sizeof()
|
||||
|
||||
return
|
||||
end function z_rkr_solver_sizeof
|
||||
|
||||
|
||||
subroutine z_rkr_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_rkr_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine z_rkr_solver_check
|
||||
|
||||
subroutine z_rkr_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
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
|
||||
character(len=20) :: name='z_rkr_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_IRST')
|
||||
sv%irst = val
|
||||
case('RKR_ISTOPC')
|
||||
sv%istopc = val
|
||||
case('RKR_ITMAX')
|
||||
sv%itmax = val
|
||||
case('RKR_ITRACE')
|
||||
sv%itrace = val
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%i_sub_solve = val
|
||||
case('RKR_FILLIN')
|
||||
sv%fillin = val
|
||||
case default
|
||||
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_rkr_solver_cseti
|
||||
|
||||
subroutine z_rkr_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
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, ival
|
||||
character(len=20) :: name='z_rkr_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('RKR_METHOD')
|
||||
sv%method = psb_toupper(trim(val))
|
||||
case('RKR_KPREC')
|
||||
sv%kprec = psb_toupper(trim(val))
|
||||
case('RKR_SUB_SOLVE')
|
||||
sv%sub_solve = psb_toupper(trim(val))
|
||||
case('RKR_GLOBAL')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('LOCAL','FALSE')
|
||||
sv%global = .false.
|
||||
case('GLOBAL','TRUE')
|
||||
sv%global =.true.
|
||||
end select
|
||||
case default
|
||||
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
call psb_errpush(info, name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_rkr_solver_csetc
|
||||
|
||||
subroutine z_rkr_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_rkr_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('RKR_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_rkr_solver_csetr
|
||||
|
||||
subroutine z_rkr_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='z_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%prec%free(info)
|
||||
call sv%a_local%free()
|
||||
call sv%x_local%free(info)
|
||||
call sv%z_local%free(info)
|
||||
if ((.not.sv%global).and.sv%desc_local%is_ok()) then
|
||||
l_ctxt=sv%desc_local%get_context()
|
||||
call psb_exit(l_ctxt,close=.false.)
|
||||
end if
|
||||
call sv%desc_local%free(info)
|
||||
nullify(sv%a)
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine z_rkr_solver_clear_data
|
||||
|
||||
|
||||
subroutine z_rkr_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_ctxt_type) :: l_ctxt
|
||||
character(len=20) :: name='z_rkr_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%clear_data(info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
end subroutine z_rkr_solver_free
|
||||
|
||||
function z_rkr_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "RKR solver"
|
||||
end function z_rkr_solver_get_fmt
|
||||
|
||||
subroutine z_rkr_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_z_rkr_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
if (sv%global) then
|
||||
write(iout_,*) ' Recursive Krylov solver (global)'
|
||||
else
|
||||
write(iout_,*) ' Recursive Krylov solver (local) '
|
||||
end if
|
||||
write(iout_,*) ' method: ',sv%method
|
||||
write(iout_,*) ' kprec: ',sv%kprec
|
||||
if (sv%i_sub_solve > 0) then
|
||||
write(iout_,*) ' sub_solve: ',amg_fact_names(sv%i_sub_solve)
|
||||
else
|
||||
write(iout_,*) ' sub_solve: ',sv%sub_solve
|
||||
end if
|
||||
write(iout_,*) ' itmax: ',sv%itmax
|
||||
write(iout_,*) ' eps: ',sv%eps
|
||||
write(iout_,*) ' fillin: ',sv%fillin
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_rkr_solver_descr
|
||||
|
||||
subroutine z_rkr_solver_cnv(sv,info,amold,vmold,imold)
|
||||
implicit none
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
|
||||
call sv%prec%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
end subroutine z_rkr_solver_cnv
|
||||
|
||||
subroutine z_rkr_solver_clone(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
call svout%free(info)
|
||||
allocate(svout,stat=info,mold=sv)
|
||||
select type(so=>svout)
|
||||
class is(amg_z_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
call sv%a_local%clone(so%a_local,info)
|
||||
call sv%desc_local%clone(so%desc_local,info)
|
||||
call sv%prec%clone(so%prec,info)
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine z_rkr_solver_clone
|
||||
|
||||
|
||||
subroutine z_rkr_solver_clone_settings(sv,svout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
class(amg_z_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(so=>svout)
|
||||
class is(amg_z_rkr_solver_type)
|
||||
so%method = sv%method
|
||||
so%kprec = sv%kprec
|
||||
so%sub_solve = sv%sub_solve
|
||||
so%i_sub_solve = sv%i_sub_solve
|
||||
so%fillin = sv%fillin
|
||||
so%irst = sv%irst
|
||||
so%istopc = sv%istopc
|
||||
so%itmax = sv%itmax
|
||||
so%itrace = sv%itrace
|
||||
so%global = sv%global
|
||||
so%eps = sv%eps
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
end subroutine z_rkr_solver_clone_settings
|
||||
|
||||
subroutine z_rkr_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
implicit none
|
||||
class(amg_z_rkr_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
|
||||
|
||||
call sv%prec%dump(info,prefix=prefix,head=head)
|
||||
|
||||
end subroutine z_rkr_solver_dmp
|
||||
!
|
||||
! Notify whether RKR is used as a global solver
|
||||
!
|
||||
function z_rkr_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(amg_z_rkr_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%global)
|
||||
end function z_rkr_solver_is_global
|
||||
!
|
||||
function z_rkr_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function z_rkr_solver_is_iterative
|
||||
|
||||
end module amg_z_rkr_solver
|
||||
@@ -334,7 +334,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
if (i==2) then
|
||||
sizeratio = desc_a%get_global_rows()/sizeratio
|
||||
else
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
|
||||
@@ -353,7 +353,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
|
||||
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
|
||||
newsz=i-1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*) trim(name),&
|
||||
@@ -388,8 +388,8 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
! We are going back and revisit a previous leve;
|
||||
! recover the aggregation.
|
||||
!
|
||||
ilaggr = prec%precv(newsz)%map%iaggr
|
||||
nlaggr = prec%precv(newsz)%map%naggr
|
||||
ilaggr = prec%precv(newsz)%linmap%iaggr
|
||||
nlaggr = prec%precv(newsz)%linmap%naggr
|
||||
call prec%precv(newsz)%tprol%clone(op_prol,info)
|
||||
end if
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
@@ -450,11 +450,36 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
|
||||
end do
|
||||
end if
|
||||
|
||||
|
||||
!write(0,*) 'Should we remap? '
|
||||
if (amg_get_do_remap().and.(np>=4)) then
|
||||
write(0,*) 'Going for remapping '
|
||||
if (.true.) then
|
||||
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
|
||||
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
|
||||
call lv%ac%clone(rmp%ac_pre_remap,info)
|
||||
if (np >= 8) then
|
||||
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
else
|
||||
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
end if
|
||||
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
|
||||
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
|
||||
lv%linmap%naggr(:) = rmp%naggr(:)
|
||||
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
end associate
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
|
||||
@@ -127,9 +127,9 @@ subroutine amg_c_hierarchy_rebld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
call prec%precv(i-1)%base_a%cp_to(acsr)
|
||||
p_desc_a => prec%precv(i-1)%base_desc
|
||||
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
|
||||
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
|
||||
& prec%precv(i)%parms,prec%precv(i)%ac,&
|
||||
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
|
||||
|
||||
|
||||
@@ -117,6 +117,10 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (me <0) then
|
||||
!!$ write(0,*) 'out of CTXT, should not do anything '
|
||||
goto 9998
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
@@ -289,6 +293,7 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
!
|
||||
! build the base preconditioner at level i
|
||||
!
|
||||
!!$ write(0,*) me,' Building at level ',i
|
||||
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -304,6 +309,7 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Exiting with',iszv,' levels'
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+304
-455
File diff suppressed because it is too large
Load Diff
+207
-193
@@ -393,38 +393,39 @@ contains
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
|
||||
end if
|
||||
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_c_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_c_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_c_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
if (me >= 0) then
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_c_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_c_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_c_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -492,28 +493,30 @@ contains
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv)
|
||||
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(cone,vx2l,czero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
if (me >= 0) then
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(cone,vx2l,czero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
call p%precv(level)%sm%apply(cone,&
|
||||
& vy2l,czero,vty,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(cone,&
|
||||
& vty,czero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(cone,&
|
||||
& vy2l,czero,vty,&
|
||||
& vx2l,czero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(cone,&
|
||||
& vty,czero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -523,7 +526,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(cone,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(cone,vx2l,&
|
||||
& czero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -543,7 +546,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(cone,&
|
||||
call p%precv(level+1)%map_prol(cone,&
|
||||
& p%precv(level+1)%wrk%vy2l, cone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -602,7 +605,6 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' inner_mult at level ',level
|
||||
end if
|
||||
@@ -623,22 +625,25 @@ contains
|
||||
!
|
||||
|
||||
if (pre) then
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vx2l,czero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
if (me >=0) then
|
||||
!!$ write(0,*) me,'Applying smoother pre ', level
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vx2l,czero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
endif
|
||||
!
|
||||
@@ -657,7 +662,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(cone,vty,&
|
||||
call p%precv(level+1)%map_rstr(cone,vty,&
|
||||
& czero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -668,7 +673,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(cone,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(cone,vx2l,&
|
||||
& czero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -684,7 +689,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(cone,&
|
||||
call p%precv(level+1)%map_prol(cone,&
|
||||
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -696,13 +701,15 @@ contains
|
||||
|
||||
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
|
||||
|
||||
call psb_geaxpby(cone,vx2l, czero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-cone,base_a,&
|
||||
& vy2l,cone,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(cone,vx2l, czero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-cone,base_a,&
|
||||
& vy2l,cone,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& call p%precv(level+1)%map%map_U2V(cone,vty,&
|
||||
& call p%precv(level+1)%map_rstr(cone,vty,&
|
||||
& czero,p%precv(level+1)%wrk%vx2l,info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
if (info /= psb_success_) then
|
||||
@@ -713,7 +720,7 @@ contains
|
||||
|
||||
call inner_ml_aply(level+1,p,trans,work,info)
|
||||
|
||||
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(cone, &
|
||||
if (info == psb_success_) call p%precv(level+1)%map_prol(cone, &
|
||||
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -728,31 +735,33 @@ contains
|
||||
|
||||
|
||||
if (post) then
|
||||
call psb_geaxpby(cone,vx2l,&
|
||||
& czero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-cone,base_a,&
|
||||
& vy2l, cone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vty,cone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vty,cone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(cone,vx2l,&
|
||||
& czero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-cone,base_a,&
|
||||
& vy2l, cone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vty,cone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vty,cone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -764,11 +773,14 @@ contains
|
||||
endif
|
||||
|
||||
else if (level == nlev) then
|
||||
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
|
||||
if (me >=0) then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
end if
|
||||
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
|
||||
|
||||
else
|
||||
|
||||
@@ -778,7 +790,7 @@ contains
|
||||
goto 9999
|
||||
end if
|
||||
end associate
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -829,72 +841,73 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,name,' start at level ',level
|
||||
end if
|
||||
|
||||
|
||||
if ((level<1).or.(level>nlev)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Invalid LEVEL>NLEV')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
!K cycle
|
||||
|
||||
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
|
||||
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv(8:))
|
||||
|
||||
if (level == nlev) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
|
||||
else if (level < nlev) then
|
||||
|
||||
if (trans == 'N') then
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
else if (level < nlev) then
|
||||
if (me >= 0) then
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vx2l,czero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(cone,vx2l,&
|
||||
& czero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-cone,base_a,&
|
||||
& vy2l,cone,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(cone,vx2l,&
|
||||
& czero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-cone,base_a,&
|
||||
& vy2l,cone,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
! Apply the restriction
|
||||
call p%precv(level + 1)%map%map_U2V(cone,vty,&
|
||||
call p%precv(level + 1)%map_rstr(cone,vty,&
|
||||
& czero,p%precv(level + 1)%wrk%vx2l,&
|
||||
&info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -930,7 +943,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(cone,&
|
||||
call p%precv(level+1)%map_prol(cone,&
|
||||
& p%precv(level+1)%wrk%vy2l,cone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -940,40 +953,42 @@ contains
|
||||
& a_err='Error during prolongation')
|
||||
goto 9999
|
||||
end if
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(cone,vx2l,&
|
||||
& czero,vty,base_desc,info)
|
||||
call psb_spmm(-cone,base_a,vy2l,&
|
||||
& cone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vty,cone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vty,cone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(cone,vx2l,&
|
||||
& czero,vty,base_desc,info)
|
||||
call psb_spmm(-cone,base_a,vy2l,&
|
||||
& cone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
|
||||
& vty,cone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
|
||||
& vty,cone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
else
|
||||
|
||||
info = psb_err_internal_error_
|
||||
@@ -990,8 +1005,7 @@ contains
|
||||
return
|
||||
|
||||
end subroutine amg_c_inner_k_cycle
|
||||
|
||||
|
||||
|
||||
recursive subroutine amg_cinneritkcycle(p, level, trans, work, innersolv)
|
||||
use psb_base_mod
|
||||
use amg_prec_mod
|
||||
@@ -1423,7 +1437,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
|
||||
& czero,mlwrk(level+1)%x2l,&
|
||||
& info,work=work)
|
||||
mlwrk(level+1)%y2l(:) = czero
|
||||
@@ -1443,7 +1457,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator and add correction.
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(cone,&
|
||||
call p%precv(level+1)%map_prol(cone,&
|
||||
& mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,&
|
||||
& info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
@@ -1564,7 +1578,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%ty,&
|
||||
call p%precv(level+1)%map_rstr(cone,mlwrk(level)%ty,&
|
||||
& czero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1573,7 +1587,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(cone,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,&
|
||||
& czero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1602,7 +1616,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(cone,mlwrk(level+1)%y2l,&
|
||||
call p%precv(level+1)%map_prol(cone,mlwrk(level+1)%y2l,&
|
||||
& cone,mlwrk(level)%y2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
|
||||
@@ -334,7 +334,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
if (i==2) then
|
||||
sizeratio = desc_a%get_global_rows()/sizeratio
|
||||
else
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
|
||||
@@ -353,7 +353,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
|
||||
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
|
||||
newsz=i-1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*) trim(name),&
|
||||
@@ -388,8 +388,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
! We are going back and revisit a previous leve;
|
||||
! recover the aggregation.
|
||||
!
|
||||
ilaggr = prec%precv(newsz)%map%iaggr
|
||||
nlaggr = prec%precv(newsz)%map%naggr
|
||||
ilaggr = prec%precv(newsz)%linmap%iaggr
|
||||
nlaggr = prec%precv(newsz)%linmap%naggr
|
||||
call prec%precv(newsz)%tprol%clone(op_prol,info)
|
||||
end if
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
@@ -450,11 +450,36 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
|
||||
end do
|
||||
end if
|
||||
|
||||
|
||||
!write(0,*) 'Should we remap? '
|
||||
if (amg_get_do_remap().and.(np>=4)) then
|
||||
write(0,*) 'Going for remapping '
|
||||
if (.true.) then
|
||||
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
|
||||
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
|
||||
call lv%ac%clone(rmp%ac_pre_remap,info)
|
||||
if (np >= 8) then
|
||||
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
else
|
||||
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
end if
|
||||
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
|
||||
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
|
||||
lv%linmap%naggr(:) = rmp%naggr(:)
|
||||
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
end associate
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
|
||||
@@ -127,9 +127,9 @@ subroutine amg_d_hierarchy_rebld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
call prec%precv(i-1)%base_a%cp_to(acsr)
|
||||
p_desc_a => prec%precv(i-1)%base_desc
|
||||
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
|
||||
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
|
||||
& prec%precv(i)%parms,prec%precv(i)%ac,&
|
||||
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
|
||||
|
||||
|
||||
@@ -117,6 +117,10 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (me <0) then
|
||||
!!$ write(0,*) 'out of CTXT, should not do anything '
|
||||
goto 9998
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
@@ -289,6 +293,7 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
!
|
||||
! build the base preconditioner at level i
|
||||
!
|
||||
!!$ write(0,*) me,' Building at level ',i
|
||||
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -304,6 +309,7 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Exiting with',iszv,' levels'
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+335
-513
File diff suppressed because it is too large
Load Diff
+207
-193
@@ -393,38 +393,39 @@ contains
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
|
||||
end if
|
||||
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_d_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_d_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_d_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
if (me >= 0) then
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_d_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_d_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_d_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -492,28 +493,30 @@ contains
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv)
|
||||
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(done,vx2l,dzero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
if (me >= 0) then
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(done,vx2l,dzero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
call p%precv(level)%sm%apply(done,&
|
||||
& vy2l,dzero,vty,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(done,&
|
||||
& vty,dzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(done,&
|
||||
& vy2l,dzero,vty,&
|
||||
& vx2l,dzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(done,&
|
||||
& vty,dzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -523,7 +526,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(done,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(done,vx2l,&
|
||||
& dzero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -543,7 +546,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(done,&
|
||||
call p%precv(level+1)%map_prol(done,&
|
||||
& p%precv(level+1)%wrk%vy2l, done,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -602,7 +605,6 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' inner_mult at level ',level
|
||||
end if
|
||||
@@ -623,22 +625,25 @@ contains
|
||||
!
|
||||
|
||||
if (pre) then
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vx2l,dzero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
if (me >=0) then
|
||||
!!$ write(0,*) me,'Applying smoother pre ', level
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vx2l,dzero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
endif
|
||||
!
|
||||
@@ -657,7 +662,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(done,vty,&
|
||||
call p%precv(level+1)%map_rstr(done,vty,&
|
||||
& dzero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -668,7 +673,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(done,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(done,vx2l,&
|
||||
& dzero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -684,7 +689,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(done,&
|
||||
call p%precv(level+1)%map_prol(done,&
|
||||
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -696,13 +701,15 @@ contains
|
||||
|
||||
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
|
||||
|
||||
call psb_geaxpby(done,vx2l, dzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-done,base_a,&
|
||||
& vy2l,done,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(done,vx2l, dzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-done,base_a,&
|
||||
& vy2l,done,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& call p%precv(level+1)%map%map_U2V(done,vty,&
|
||||
& call p%precv(level+1)%map_rstr(done,vty,&
|
||||
& dzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
if (info /= psb_success_) then
|
||||
@@ -713,7 +720,7 @@ contains
|
||||
|
||||
call inner_ml_aply(level+1,p,trans,work,info)
|
||||
|
||||
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(done, &
|
||||
if (info == psb_success_) call p%precv(level+1)%map_prol(done, &
|
||||
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -728,31 +735,33 @@ contains
|
||||
|
||||
|
||||
if (post) then
|
||||
call psb_geaxpby(done,vx2l,&
|
||||
& dzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-done,base_a,&
|
||||
& vy2l, done,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vty,done,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vty,done,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(done,vx2l,&
|
||||
& dzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-done,base_a,&
|
||||
& vy2l, done,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vty,done,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vty,done,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -764,11 +773,14 @@ contains
|
||||
endif
|
||||
|
||||
else if (level == nlev) then
|
||||
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
|
||||
if (me >=0) then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
end if
|
||||
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
|
||||
|
||||
else
|
||||
|
||||
@@ -778,7 +790,7 @@ contains
|
||||
goto 9999
|
||||
end if
|
||||
end associate
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -829,72 +841,73 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,name,' start at level ',level
|
||||
end if
|
||||
|
||||
|
||||
if ((level<1).or.(level>nlev)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Invalid LEVEL>NLEV')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
!K cycle
|
||||
|
||||
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
|
||||
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv(8:))
|
||||
|
||||
if (level == nlev) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
|
||||
else if (level < nlev) then
|
||||
|
||||
if (trans == 'N') then
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
else if (level < nlev) then
|
||||
if (me >= 0) then
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vx2l,dzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(done,vx2l,&
|
||||
& dzero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-done,base_a,&
|
||||
& vy2l,done,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(done,vx2l,&
|
||||
& dzero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-done,base_a,&
|
||||
& vy2l,done,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
! Apply the restriction
|
||||
call p%precv(level + 1)%map%map_U2V(done,vty,&
|
||||
call p%precv(level + 1)%map_rstr(done,vty,&
|
||||
& dzero,p%precv(level + 1)%wrk%vx2l,&
|
||||
&info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -930,7 +943,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(done,&
|
||||
call p%precv(level+1)%map_prol(done,&
|
||||
& p%precv(level+1)%wrk%vy2l,done,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -940,40 +953,42 @@ contains
|
||||
& a_err='Error during prolongation')
|
||||
goto 9999
|
||||
end if
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(done,vx2l,&
|
||||
& dzero,vty,base_desc,info)
|
||||
call psb_spmm(-done,base_a,vy2l,&
|
||||
& done,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vty,done,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vty,done,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(done,vx2l,&
|
||||
& dzero,vty,base_desc,info)
|
||||
call psb_spmm(-done,base_a,vy2l,&
|
||||
& done,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
||||
& vty,done,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
||||
& vty,done,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
else
|
||||
|
||||
info = psb_err_internal_error_
|
||||
@@ -990,8 +1005,7 @@ contains
|
||||
return
|
||||
|
||||
end subroutine amg_d_inner_k_cycle
|
||||
|
||||
|
||||
|
||||
recursive subroutine amg_dinneritkcycle(p, level, trans, work, innersolv)
|
||||
use psb_base_mod
|
||||
use amg_prec_mod
|
||||
@@ -1423,7 +1437,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
|
||||
& dzero,mlwrk(level+1)%x2l,&
|
||||
& info,work=work)
|
||||
mlwrk(level+1)%y2l(:) = dzero
|
||||
@@ -1443,7 +1457,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator and add correction.
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(done,&
|
||||
call p%precv(level+1)%map_prol(done,&
|
||||
& mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,&
|
||||
& info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
@@ -1564,7 +1578,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%ty,&
|
||||
call p%precv(level+1)%map_rstr(done,mlwrk(level)%ty,&
|
||||
& dzero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1573,7 +1587,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(done,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,&
|
||||
& dzero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1602,7 +1616,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(done,mlwrk(level+1)%y2l,&
|
||||
call p%precv(level+1)%map_prol(done,mlwrk(level+1)%y2l,&
|
||||
& done,mlwrk(level)%y2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
|
||||
@@ -334,7 +334,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
if (i==2) then
|
||||
sizeratio = desc_a%get_global_rows()/sizeratio
|
||||
else
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
|
||||
@@ -353,7 +353,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
|
||||
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
|
||||
newsz=i-1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*) trim(name),&
|
||||
@@ -388,8 +388,8 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
! We are going back and revisit a previous leve;
|
||||
! recover the aggregation.
|
||||
!
|
||||
ilaggr = prec%precv(newsz)%map%iaggr
|
||||
nlaggr = prec%precv(newsz)%map%naggr
|
||||
ilaggr = prec%precv(newsz)%linmap%iaggr
|
||||
nlaggr = prec%precv(newsz)%linmap%naggr
|
||||
call prec%precv(newsz)%tprol%clone(op_prol,info)
|
||||
end if
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
@@ -450,11 +450,36 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
|
||||
end do
|
||||
end if
|
||||
|
||||
|
||||
!write(0,*) 'Should we remap? '
|
||||
if (amg_get_do_remap().and.(np>=4)) then
|
||||
write(0,*) 'Going for remapping '
|
||||
if (.true.) then
|
||||
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
|
||||
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
|
||||
call lv%ac%clone(rmp%ac_pre_remap,info)
|
||||
if (np >= 8) then
|
||||
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
else
|
||||
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
end if
|
||||
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
|
||||
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
|
||||
lv%linmap%naggr(:) = rmp%naggr(:)
|
||||
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
end associate
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
|
||||
@@ -127,9 +127,9 @@ subroutine amg_s_hierarchy_rebld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
call prec%precv(i-1)%base_a%cp_to(acsr)
|
||||
p_desc_a => prec%precv(i-1)%base_desc
|
||||
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
|
||||
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
|
||||
& prec%precv(i)%parms,prec%precv(i)%ac,&
|
||||
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
|
||||
|
||||
|
||||
@@ -117,6 +117,10 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (me <0) then
|
||||
!!$ write(0,*) 'out of CTXT, should not do anything '
|
||||
goto 9998
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
@@ -289,6 +293,7 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
!
|
||||
! build the base preconditioner at level i
|
||||
!
|
||||
!!$ write(0,*) me,' Building at level ',i
|
||||
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -304,6 +309,7 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Exiting with',iszv,' levels'
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+304
-455
File diff suppressed because it is too large
Load Diff
+207
-193
@@ -393,38 +393,39 @@ contains
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
|
||||
end if
|
||||
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_s_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_s_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_s_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
if (me >= 0) then
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_s_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_s_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_s_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -492,28 +493,30 @@ contains
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv)
|
||||
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(sone,vx2l,szero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
if (me >= 0) then
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(sone,vx2l,szero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
call p%precv(level)%sm%apply(sone,&
|
||||
& vy2l,szero,vty,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(sone,&
|
||||
& vty,szero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(sone,&
|
||||
& vy2l,szero,vty,&
|
||||
& vx2l,szero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(sone,&
|
||||
& vty,szero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -523,7 +526,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(sone,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(sone,vx2l,&
|
||||
& szero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -543,7 +546,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(sone,&
|
||||
call p%precv(level+1)%map_prol(sone,&
|
||||
& p%precv(level+1)%wrk%vy2l, sone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -602,7 +605,6 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' inner_mult at level ',level
|
||||
end if
|
||||
@@ -623,22 +625,25 @@ contains
|
||||
!
|
||||
|
||||
if (pre) then
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vx2l,szero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
if (me >=0) then
|
||||
!!$ write(0,*) me,'Applying smoother pre ', level
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vx2l,szero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
endif
|
||||
!
|
||||
@@ -657,7 +662,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(sone,vty,&
|
||||
call p%precv(level+1)%map_rstr(sone,vty,&
|
||||
& szero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -668,7 +673,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(sone,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(sone,vx2l,&
|
||||
& szero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -684,7 +689,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(sone,&
|
||||
call p%precv(level+1)%map_prol(sone,&
|
||||
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -696,13 +701,15 @@ contains
|
||||
|
||||
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
|
||||
|
||||
call psb_geaxpby(sone,vx2l, szero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-sone,base_a,&
|
||||
& vy2l,sone,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(sone,vx2l, szero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-sone,base_a,&
|
||||
& vy2l,sone,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& call p%precv(level+1)%map%map_U2V(sone,vty,&
|
||||
& call p%precv(level+1)%map_rstr(sone,vty,&
|
||||
& szero,p%precv(level+1)%wrk%vx2l,info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
if (info /= psb_success_) then
|
||||
@@ -713,7 +720,7 @@ contains
|
||||
|
||||
call inner_ml_aply(level+1,p,trans,work,info)
|
||||
|
||||
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(sone, &
|
||||
if (info == psb_success_) call p%precv(level+1)%map_prol(sone, &
|
||||
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -728,31 +735,33 @@ contains
|
||||
|
||||
|
||||
if (post) then
|
||||
call psb_geaxpby(sone,vx2l,&
|
||||
& szero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-sone,base_a,&
|
||||
& vy2l, sone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vty,sone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vty,sone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(sone,vx2l,&
|
||||
& szero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-sone,base_a,&
|
||||
& vy2l, sone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vty,sone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vty,sone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -764,11 +773,14 @@ contains
|
||||
endif
|
||||
|
||||
else if (level == nlev) then
|
||||
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
|
||||
if (me >=0) then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
end if
|
||||
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
|
||||
|
||||
else
|
||||
|
||||
@@ -778,7 +790,7 @@ contains
|
||||
goto 9999
|
||||
end if
|
||||
end associate
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -829,72 +841,73 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,name,' start at level ',level
|
||||
end if
|
||||
|
||||
|
||||
if ((level<1).or.(level>nlev)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Invalid LEVEL>NLEV')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
!K cycle
|
||||
|
||||
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
|
||||
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv(8:))
|
||||
|
||||
if (level == nlev) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
|
||||
else if (level < nlev) then
|
||||
|
||||
if (trans == 'N') then
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
else if (level < nlev) then
|
||||
if (me >= 0) then
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vx2l,szero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(sone,vx2l,&
|
||||
& szero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-sone,base_a,&
|
||||
& vy2l,sone,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(sone,vx2l,&
|
||||
& szero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-sone,base_a,&
|
||||
& vy2l,sone,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
! Apply the restriction
|
||||
call p%precv(level + 1)%map%map_U2V(sone,vty,&
|
||||
call p%precv(level + 1)%map_rstr(sone,vty,&
|
||||
& szero,p%precv(level + 1)%wrk%vx2l,&
|
||||
&info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -930,7 +943,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(sone,&
|
||||
call p%precv(level+1)%map_prol(sone,&
|
||||
& p%precv(level+1)%wrk%vy2l,sone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -940,40 +953,42 @@ contains
|
||||
& a_err='Error during prolongation')
|
||||
goto 9999
|
||||
end if
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(sone,vx2l,&
|
||||
& szero,vty,base_desc,info)
|
||||
call psb_spmm(-sone,base_a,vy2l,&
|
||||
& sone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vty,sone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vty,sone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(sone,vx2l,&
|
||||
& szero,vty,base_desc,info)
|
||||
call psb_spmm(-sone,base_a,vy2l,&
|
||||
& sone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
|
||||
& vty,sone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
|
||||
& vty,sone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
else
|
||||
|
||||
info = psb_err_internal_error_
|
||||
@@ -990,8 +1005,7 @@ contains
|
||||
return
|
||||
|
||||
end subroutine amg_s_inner_k_cycle
|
||||
|
||||
|
||||
|
||||
recursive subroutine amg_sinneritkcycle(p, level, trans, work, innersolv)
|
||||
use psb_base_mod
|
||||
use amg_prec_mod
|
||||
@@ -1423,7 +1437,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
|
||||
& szero,mlwrk(level+1)%x2l,&
|
||||
& info,work=work)
|
||||
mlwrk(level+1)%y2l(:) = szero
|
||||
@@ -1443,7 +1457,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator and add correction.
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(sone,&
|
||||
call p%precv(level+1)%map_prol(sone,&
|
||||
& mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,&
|
||||
& info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
@@ -1564,7 +1578,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%ty,&
|
||||
call p%precv(level+1)%map_rstr(sone,mlwrk(level)%ty,&
|
||||
& szero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1573,7 +1587,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(sone,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,&
|
||||
& szero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1602,7 +1616,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(sone,mlwrk(level+1)%y2l,&
|
||||
call p%precv(level+1)%map_prol(sone,mlwrk(level+1)%y2l,&
|
||||
& sone,mlwrk(level)%y2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
|
||||
@@ -334,7 +334,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
if (i==2) then
|
||||
sizeratio = desc_a%get_global_rows()/sizeratio
|
||||
else
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
sizeratio = sum(prec%precv(i-1)%linmap%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
|
||||
@@ -353,7 +353,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
end if
|
||||
|
||||
if (all(nlaggr == prec%precv(i-1)%map%naggr)) then
|
||||
if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then
|
||||
newsz=i-1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*) trim(name),&
|
||||
@@ -388,8 +388,8 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
! We are going back and revisit a previous leve;
|
||||
! recover the aggregation.
|
||||
!
|
||||
ilaggr = prec%precv(newsz)%map%iaggr
|
||||
nlaggr = prec%precv(newsz)%map%naggr
|
||||
ilaggr = prec%precv(newsz)%linmap%iaggr
|
||||
nlaggr = prec%precv(newsz)%linmap%naggr
|
||||
call prec%precv(newsz)%tprol%clone(op_prol,info)
|
||||
end if
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
@@ -450,11 +450,36 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
prec%precv(i)%map%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%map%p_desc_V => prec%precv(i)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
|
||||
prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
|
||||
end do
|
||||
end if
|
||||
|
||||
|
||||
!write(0,*) 'Should we remap? '
|
||||
if (amg_get_do_remap().and.(np>=4)) then
|
||||
write(0,*) 'Going for remapping '
|
||||
if (.true.) then
|
||||
associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data)
|
||||
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
|
||||
call lv%ac%clone(rmp%ac_pre_remap,info)
|
||||
if (np >= 8) then
|
||||
call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
else
|
||||
call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
|
||||
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
|
||||
end if
|
||||
write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
|
||||
& lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
|
||||
lv%linmap%naggr(:) = rmp%naggr(:)
|
||||
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
end associate
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
|
||||
@@ -127,9 +127,9 @@ subroutine amg_z_hierarchy_rebld(a,desc_a,prec,info)
|
||||
do i=2, iszv
|
||||
call prec%precv(i-1)%base_a%cp_to(acsr)
|
||||
p_desc_a => prec%precv(i-1)%base_desc
|
||||
call prec%precv(i)%map%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%map%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%map%naggr,&
|
||||
call prec%precv(i)%linmap%mat_V2U%cp_to(coo_prol)
|
||||
call prec%precv(i)%linmap%mat_U2V%cp_to(coo_restr)
|
||||
call amg_rap(acsr,p_desc_a,prec%precv(i)%linmap%naggr,&
|
||||
& prec%precv(i)%parms,prec%precv(i)%ac,&
|
||||
& coo_prol,prec%precv(i)%desc_ac,coo_restr,info)
|
||||
|
||||
|
||||
@@ -117,6 +117,10 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (me <0) then
|
||||
!!$ write(0,*) 'out of CTXT, should not do anything '
|
||||
goto 9998
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
@@ -289,6 +293,7 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
!
|
||||
! build the base preconditioner at level i
|
||||
!
|
||||
!!$ write(0,*) me,' Building at level ',i
|
||||
call prec%precv(i)%bld(info,amold=amold,vmold=vmold,imold=imold,ilv=i)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -304,6 +309,7 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Exiting with',iszv,' levels'
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
+335
-513
File diff suppressed because it is too large
Load Diff
+207
-193
@@ -393,38 +393,39 @@ contains
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info
|
||||
end if
|
||||
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_z_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_z_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_z_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
if (me >= 0) then
|
||||
select case(p%precv(level)%parms%ml_cycle)
|
||||
|
||||
case(amg_no_ml_)
|
||||
!
|
||||
! No preconditioning, should not really get here
|
||||
!
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='amg_no_ml_ in mlprc_aply?')
|
||||
goto 9999
|
||||
|
||||
case(amg_add_ml_)
|
||||
|
||||
call amg_z_inner_add(p, level, trans, work)
|
||||
|
||||
case(amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_)
|
||||
|
||||
call amg_z_inner_mult(p, level, trans, work)
|
||||
|
||||
case(amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
|
||||
call amg_z_inner_k_cycle(p, level, trans, work)
|
||||
|
||||
case default
|
||||
info = psb_err_from_subroutine_ai_
|
||||
call psb_errpush(info,name,a_err='invalid ml_cycle',&
|
||||
& i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
end select
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' End inner_ml_aply at level ',level
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -492,28 +493,30 @@ contains
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv)
|
||||
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(zone,vx2l,zzero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
if (me >= 0) then
|
||||
if (allocated(p%precv(level)%sm2a)) then
|
||||
call psb_geaxpby(zone,vx2l,zzero,vy2l,base_desc,info)
|
||||
|
||||
sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post)
|
||||
do k=1, sweeps
|
||||
call p%precv(level)%sm%apply(zone,&
|
||||
& vy2l,zzero,vty,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(zone,&
|
||||
& vty,zzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(zone,&
|
||||
& vy2l,zzero,vty,&
|
||||
& vx2l,zzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
|
||||
call p%precv(level)%sm2a%apply(zone,&
|
||||
& vty,zzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& ione,work,wv,info,init='Z')
|
||||
end do
|
||||
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,&
|
||||
& base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -523,7 +526,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(zone,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(zone,vx2l,&
|
||||
& zzero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -543,7 +546,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(zone,&
|
||||
call p%precv(level+1)%map_prol(zone,&
|
||||
& p%precv(level+1)%wrk%vy2l, zone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -602,7 +605,6 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,' inner_mult at level ',level
|
||||
end if
|
||||
@@ -623,22 +625,25 @@ contains
|
||||
!
|
||||
|
||||
if (pre) then
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vx2l,zzero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
if (me >=0) then
|
||||
!!$ write(0,*) me,'Applying smoother pre ', level
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vx2l,zzero,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
endif
|
||||
!
|
||||
@@ -657,7 +662,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(zone,vty,&
|
||||
call p%precv(level+1)%map_rstr(zone,vty,&
|
||||
& zzero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -668,7 +673,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(zone,vx2l,&
|
||||
call p%precv(level+1)%map_rstr(zone,vx2l,&
|
||||
& zzero,p%precv(level+1)%wrk%vx2l,&
|
||||
& info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -684,7 +689,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(zone,&
|
||||
call p%precv(level+1)%map_prol(zone,&
|
||||
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -696,13 +701,15 @@ contains
|
||||
|
||||
if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then
|
||||
|
||||
call psb_geaxpby(zone,vx2l, zzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-zone,base_a,&
|
||||
& vy2l,zone,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(zone,vx2l, zzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-zone,base_a,&
|
||||
& vy2l,zone,vty,&
|
||||
& base_desc,info,work=work,trans=trans)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& call p%precv(level+1)%map%map_U2V(zone,vty,&
|
||||
& call p%precv(level+1)%map_rstr(zone,vty,&
|
||||
& zzero,p%precv(level+1)%wrk%vx2l,info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
if (info /= psb_success_) then
|
||||
@@ -713,7 +720,7 @@ contains
|
||||
|
||||
call inner_ml_aply(level+1,p,trans,work,info)
|
||||
|
||||
if (info == psb_success_) call p%precv(level+1)%map%map_V2U(zone, &
|
||||
if (info == psb_success_) call p%precv(level+1)%map_prol(zone, &
|
||||
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -728,31 +735,33 @@ contains
|
||||
|
||||
|
||||
if (post) then
|
||||
call psb_geaxpby(zone,vx2l,&
|
||||
& zzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-zone,base_a,&
|
||||
& vy2l, zone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vty,zone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vty,zone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (me >=0) then
|
||||
call psb_geaxpby(zone,vx2l,&
|
||||
& zzero,vty,&
|
||||
& base_desc,info)
|
||||
if (info == psb_success_) call psb_spmm(-zone,base_a,&
|
||||
& vy2l, zone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Apply the second smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vty,zone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vty,zone,vy2l, base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
@@ -764,11 +773,14 @@ contains
|
||||
endif
|
||||
|
||||
else if (level == nlev) then
|
||||
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
!!$ write(0,*) me,'Applying smoother at top level ',psb_errstatus_fatal()
|
||||
if (me >=0) then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info)
|
||||
end if
|
||||
!!$ write(0,*) me,' Done applying smoother at top level ',psb_errstatus_fatal()
|
||||
|
||||
else
|
||||
|
||||
@@ -778,7 +790,7 @@ contains
|
||||
goto 9999
|
||||
end if
|
||||
end associate
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -829,72 +841,73 @@ contains
|
||||
end if
|
||||
ctxt = p%precv(level)%base_desc%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
|
||||
|
||||
if(debug_level > 1) then
|
||||
write(debug_unit,*) me,name,' start at level ',level
|
||||
end if
|
||||
|
||||
|
||||
if ((level<1).or.(level>nlev)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Invalid LEVEL>NLEV')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
!K cycle
|
||||
|
||||
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
|
||||
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
|
||||
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
|
||||
& wv => p%precv(level)%wrk%wv(8:))
|
||||
|
||||
if (level == nlev) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
|
||||
else if (level < nlev) then
|
||||
|
||||
if (trans == 'N') then
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Apply smoother
|
||||
!
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
else if (level < nlev) then
|
||||
if (me >= 0) then
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vx2l,zzero,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during 2-PRE smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(zone,vx2l,&
|
||||
& zzero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-zone,base_a,&
|
||||
& vy2l,zone,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
!
|
||||
! Compute the residual and call recursively
|
||||
!
|
||||
|
||||
call psb_geaxpby(zone,vx2l,&
|
||||
& zzero,vty,&
|
||||
& base_desc,info)
|
||||
|
||||
if (info == psb_success_) call psb_spmm(-zone,base_a,&
|
||||
& vy2l,zone,vty,base_desc,info,work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
! Apply the restriction
|
||||
call p%precv(level + 1)%map%map_U2V(zone,vty,&
|
||||
call p%precv(level + 1)%map_rstr(zone,vty,&
|
||||
& zzero,p%precv(level + 1)%wrk%vx2l,&
|
||||
&info,work=work,&
|
||||
& vtx=wv(1),vty=p%precv(level+1)%wrk%wv(1))
|
||||
@@ -930,7 +943,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(zone,&
|
||||
call p%precv(level+1)%map_prol(zone,&
|
||||
& p%precv(level+1)%wrk%vy2l,zone,vy2l,&
|
||||
& info,work=work,&
|
||||
& vtx=p%precv(level+1)%wrk%wv(1),vty=wv(1))
|
||||
@@ -940,40 +953,42 @@ contains
|
||||
& a_err='Error during prolongation')
|
||||
goto 9999
|
||||
end if
|
||||
if (me >= 0) then
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(zone,vx2l,&
|
||||
& zzero,vty,base_desc,info)
|
||||
call psb_spmm(-zone,base_a,vy2l,&
|
||||
& zone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vty,zone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vty,zone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute the residual
|
||||
!
|
||||
call psb_geaxpby(zone,vx2l,&
|
||||
& zzero,vty,base_desc,info)
|
||||
call psb_spmm(-zone,base_a,vy2l,&
|
||||
& zone,vty,base_desc,info,&
|
||||
& work=work,trans=trans)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Apply the smoother
|
||||
!
|
||||
if (trans == 'N') then
|
||||
sweeps = p%precv(level)%parms%sweeps_post
|
||||
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
|
||||
& vty,zone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
else
|
||||
sweeps = p%precv(level)%parms%sweeps_pre
|
||||
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
|
||||
& vty,zone,vy2l,base_desc, trans,&
|
||||
& sweeps,work,wv,info,init='Z')
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error during POST smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
else
|
||||
|
||||
info = psb_err_internal_error_
|
||||
@@ -990,8 +1005,7 @@ contains
|
||||
return
|
||||
|
||||
end subroutine amg_z_inner_k_cycle
|
||||
|
||||
|
||||
|
||||
recursive subroutine amg_zinneritkcycle(p, level, trans, work, innersolv)
|
||||
use psb_base_mod
|
||||
use amg_prec_mod
|
||||
@@ -1423,7 +1437,7 @@ contains
|
||||
|
||||
if (level < nlev) then
|
||||
! Apply the restriction
|
||||
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
|
||||
& zzero,mlwrk(level+1)%x2l,&
|
||||
& info,work=work)
|
||||
mlwrk(level+1)%y2l(:) = zzero
|
||||
@@ -1443,7 +1457,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator and add correction.
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(zone,&
|
||||
call p%precv(level+1)%map_prol(zone,&
|
||||
& mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,&
|
||||
& info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
@@ -1564,7 +1578,7 @@ contains
|
||||
& a_err='Error during residue')
|
||||
goto 9999
|
||||
end if
|
||||
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%ty,&
|
||||
call p%precv(level+1)%map_rstr(zone,mlwrk(level)%ty,&
|
||||
& zzero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1573,7 +1587,7 @@ contains
|
||||
end if
|
||||
else
|
||||
! Shortcut: just transfer x2l.
|
||||
call p%precv(level+1)%map%map_U2V(zone,mlwrk(level)%x2l,&
|
||||
call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,&
|
||||
& zzero,mlwrk(level+1)%x2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -1602,7 +1616,7 @@ contains
|
||||
!
|
||||
! Apply the prolongator
|
||||
!
|
||||
call p%precv(level+1)%map%map_V2U(zone,mlwrk(level+1)%y2l,&
|
||||
call p%precv(level+1)%map_prol(zone,mlwrk(level+1)%y2l,&
|
||||
& zone,mlwrk(level)%y2l,info,work=work)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
|
||||
@@ -21,6 +21,8 @@ amg_c_base_onelev_mat_asb.o \
|
||||
amg_c_base_onelev_setag.o \
|
||||
amg_c_base_onelev_setsm.o \
|
||||
amg_c_base_onelev_setsv.o \
|
||||
amg_c_base_onelev_map_rstr.o \
|
||||
amg_c_base_onelev_map_prol.o \
|
||||
amg_d_base_onelev_build.o \
|
||||
amg_d_base_onelev_check.o \
|
||||
amg_d_base_onelev_cnv.o \
|
||||
@@ -34,6 +36,8 @@ amg_d_base_onelev_mat_asb.o \
|
||||
amg_d_base_onelev_setag.o \
|
||||
amg_d_base_onelev_setsm.o \
|
||||
amg_d_base_onelev_setsv.o \
|
||||
amg_d_base_onelev_map_rstr.o \
|
||||
amg_d_base_onelev_map_prol.o \
|
||||
amg_s_base_onelev_build.o \
|
||||
amg_s_base_onelev_check.o \
|
||||
amg_s_base_onelev_cnv.o \
|
||||
@@ -47,6 +51,8 @@ amg_s_base_onelev_mat_asb.o \
|
||||
amg_s_base_onelev_setag.o \
|
||||
amg_s_base_onelev_setsm.o \
|
||||
amg_s_base_onelev_setsv.o \
|
||||
amg_s_base_onelev_map_rstr.o \
|
||||
amg_s_base_onelev_map_prol.o \
|
||||
amg_z_base_onelev_build.o \
|
||||
amg_z_base_onelev_check.o \
|
||||
amg_z_base_onelev_cnv.o \
|
||||
@@ -59,7 +65,9 @@ amg_z_base_onelev_free.o \
|
||||
amg_z_base_onelev_mat_asb.o \
|
||||
amg_z_base_onelev_setag.o \
|
||||
amg_z_base_onelev_setsm.o \
|
||||
amg_z_base_onelev_setsv.o
|
||||
amg_z_base_onelev_setsv.o \
|
||||
amg_z_base_onelev_map_rstr.o \
|
||||
amg_z_base_onelev_map_prol.o
|
||||
|
||||
|
||||
LIBNAME=libamg_prec.a
|
||||
|
||||
@@ -71,72 +71,81 @@ subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
!
|
||||
! At top level(s) I may be using
|
||||
! a context with less processes
|
||||
!
|
||||
if (me < 0) then
|
||||
!!$ write(0,*) 'onelevbld: I am excluded from this one '
|
||||
else
|
||||
!!$ write(0,*) me,' Going to build smoothers at this level '
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -62,6 +62,6 @@ subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
& call lv%ac%cscnv(info,mold=amold)
|
||||
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
|
||||
& .and. present(imold)) call lv%desc_ac%cnv(imold)
|
||||
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
|
||||
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_c_base_onelev_cnv
|
||||
|
||||
@@ -1,15 +1,15 @@
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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:
|
||||
@@ -21,7 +21,7 @@
|
||||
! 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
|
||||
@@ -33,10 +33,10 @@
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetc
|
||||
use amg_c_base_aggregator_mod
|
||||
@@ -49,6 +49,9 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
use amg_c_ilu_solver
|
||||
use amg_c_id_solver
|
||||
use amg_c_gs_solver
|
||||
use amg_c_ainv_solver
|
||||
use amg_c_invk_solver
|
||||
use amg_c_invt_solver
|
||||
#if defined(HAVE_SLU_)
|
||||
use amg_c_slu_solver
|
||||
#endif
|
||||
@@ -59,16 +62,16 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
integer(psb_ipk_) :: ival
|
||||
type(amg_c_base_smoother_type) :: amg_c_base_smoother_mold
|
||||
type(amg_c_jac_smoother_type) :: amg_c_jac_smoother_mold
|
||||
type(amg_c_l1_jac_smoother_type) :: amg_c_l1_jac_smoother_mold
|
||||
@@ -79,13 +82,16 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
type(amg_c_id_solver_type) :: amg_c_id_solver_mold
|
||||
type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold
|
||||
type(amg_c_bwgs_solver_type) :: amg_c_bwgs_solver_mold
|
||||
type(amg_c_ainv_solver_type) :: amg_c_ainv_solver_mold
|
||||
type(amg_c_invk_solver_type) :: amg_c_invk_solver_mold
|
||||
type(amg_c_invt_solver_type) :: amg_c_invt_solver_mold
|
||||
#if defined(HAVE_SLU_)
|
||||
type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold
|
||||
#endif
|
||||
#if defined(HAVE_MUMPS_)
|
||||
type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
@@ -106,14 +112,14 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
|
||||
select case (psb_toupper(trim(what)))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NOPREC','NONE')
|
||||
call lv%set(amg_c_base_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('JAC','JACOBI')
|
||||
call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos)
|
||||
@@ -121,11 +127,11 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-JACOBI')
|
||||
call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BJAC')
|
||||
call lv%set(amg_c_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
|
||||
@@ -154,67 +160,73 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(amg_c_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) call lv%sm%default()
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%default()
|
||||
end if
|
||||
|
||||
|
||||
|
||||
case('SUB_SOLVE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NONE','NOPREC','FACT_NONE')
|
||||
call lv%set(amg_c_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('DIAG')
|
||||
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-DIAG')
|
||||
call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('GS','FGS','FWGS')
|
||||
call lv%set(amg_c_gs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('AINV')
|
||||
call lv%set(amg_c_ainv_solver_mold,info,pos=pos)
|
||||
case ('INVK')
|
||||
call lv%set(amg_c_invk_solver_mold,info,pos=pos)
|
||||
case ('INVT')
|
||||
call lv%set(amg_c_invt_solver_mold,info,pos=pos)
|
||||
case ('ILU','ILUT','MILU')
|
||||
call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
|
||||
if (info == 0) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
end if
|
||||
#ifdef HAVE_SLU_
|
||||
case ('SLU')
|
||||
case ('SLU')
|
||||
call lv%set(amg_c_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case ('MUMPS')
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
@@ -229,7 +241,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
select case(ival)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
@@ -239,7 +251,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
@@ -266,13 +278,13 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
lv%parms%coarse_solve = amg_stringval(val)
|
||||
|
||||
case default
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -89,11 +89,11 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout)
|
||||
call lv%parms%descr(iout_,info,coarse=coarse)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%map%naggr)) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) ' Coarse Matrix: Global size: ', &
|
||||
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
write(iout_,*) ' Local matrix sizes: ', &
|
||||
& lv%map%naggr(:)
|
||||
& lv%linmap%naggr(:)
|
||||
write(iout_,*) ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
|
||||
@@ -108,17 +108,17 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
end if
|
||||
if (tprol_) then
|
||||
! Tentative prolongator is stored with column indices already
|
||||
! in global numbering, so only IVR is needed.
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
! This is not implemented yet.
|
||||
@@ -133,9 +133,9 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head)
|
||||
end if
|
||||
if (tprol_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
|
||||
@@ -63,7 +63,7 @@ subroutine amg_c_base_onelev_free(lv,info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%map%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
|
||||
@@ -0,0 +1,135 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_prol_v
|
||||
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_c_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
rrcv = vect_v%get_vect()
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
|
||||
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
end if
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
|
||||
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
|
||||
call psb_realloc(nrc,rsnd,info)
|
||||
call psb_rcv(ctxt,rsnd(1:nrl),idest)
|
||||
call tv%set_vect(rsnd)
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Prolongator with remap done '
|
||||
!!$ flush(0)
|
||||
!!$ call psb_barrier(ctxt)
|
||||
end block
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_map_prol_v
|
||||
|
||||
subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_prol_a
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
complex(psb_spk_), intent(inout) :: u(:)
|
||||
complex(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_map_prol_a
|
||||
@@ -0,0 +1,129 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_rstr_v
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling not implemented yet '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_c_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
|
||||
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
rsnd = tv%get_vect()
|
||||
call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
|
||||
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
call vect_v%set_vect(rrcv)
|
||||
end if
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Restrictor with remap done '
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_map_rstr_v
|
||||
|
||||
subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_rstr_a
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
complex(psb_spk_), intent(inout) :: u(:)
|
||||
complex(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_map_rstr_a
|
||||
@@ -53,7 +53,7 @@
|
||||
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
|
||||
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
|
||||
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
|
||||
! 4. Pack restrictor and prolongator into p%map
|
||||
! 4. Pack restrictor and prolongator into p%linmap
|
||||
! 5. Fix base_a and base_desc pointers.
|
||||
!
|
||||
!
|
||||
@@ -158,7 +158,7 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
|
||||
@@ -71,72 +71,81 @@ subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
!
|
||||
! At top level(s) I may be using
|
||||
! a context with less processes
|
||||
!
|
||||
if (me < 0) then
|
||||
!!$ write(0,*) 'onelevbld: I am excluded from this one '
|
||||
else
|
||||
!!$ write(0,*) me,' Going to build smoothers at this level '
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -62,6 +62,6 @@ subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
& call lv%ac%cscnv(info,mold=amold)
|
||||
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
|
||||
& .and. present(imold)) call lv%desc_ac%cnv(imold)
|
||||
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
|
||||
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_d_base_onelev_cnv
|
||||
|
||||
@@ -1,15 +1,15 @@
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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:
|
||||
@@ -21,7 +21,7 @@
|
||||
! 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
|
||||
@@ -33,10 +33,10 @@
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetc
|
||||
use amg_d_base_aggregator_mod
|
||||
@@ -49,6 +49,9 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
use amg_d_ilu_solver
|
||||
use amg_d_id_solver
|
||||
use amg_d_gs_solver
|
||||
use amg_d_ainv_solver
|
||||
use amg_d_invk_solver
|
||||
use amg_d_invt_solver
|
||||
#if defined(HAVE_UMF_)
|
||||
use amg_d_umf_solver
|
||||
#endif
|
||||
@@ -65,16 +68,16 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
integer(psb_ipk_) :: ival
|
||||
type(amg_d_base_smoother_type) :: amg_d_base_smoother_mold
|
||||
type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold
|
||||
type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold
|
||||
@@ -85,6 +88,9 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
type(amg_d_id_solver_type) :: amg_d_id_solver_mold
|
||||
type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold
|
||||
type(amg_d_bwgs_solver_type) :: amg_d_bwgs_solver_mold
|
||||
type(amg_d_ainv_solver_type) :: amg_d_ainv_solver_mold
|
||||
type(amg_d_invk_solver_type) :: amg_d_invk_solver_mold
|
||||
type(amg_d_invt_solver_type) :: amg_d_invt_solver_mold
|
||||
#if defined(HAVE_UMF_)
|
||||
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
|
||||
#endif
|
||||
@@ -97,7 +103,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
#if defined(HAVE_MUMPS_)
|
||||
type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
@@ -118,14 +124,14 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
|
||||
select case (psb_toupper(trim(what)))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NOPREC','NONE')
|
||||
call lv%set(amg_d_base_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('JAC','JACOBI')
|
||||
call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos)
|
||||
@@ -133,11 +139,11 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-JACOBI')
|
||||
call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BJAC')
|
||||
call lv%set(amg_d_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
|
||||
@@ -166,59 +172,65 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(amg_d_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) call lv%sm%default()
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%default()
|
||||
end if
|
||||
|
||||
|
||||
|
||||
case('SUB_SOLVE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NONE','NOPREC','FACT_NONE')
|
||||
call lv%set(amg_d_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('DIAG')
|
||||
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-DIAG')
|
||||
call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('GS','FGS','FWGS')
|
||||
call lv%set(amg_d_gs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('AINV')
|
||||
call lv%set(amg_d_ainv_solver_mold,info,pos=pos)
|
||||
case ('INVK')
|
||||
call lv%set(amg_d_invk_solver_mold,info,pos=pos)
|
||||
case ('INVT')
|
||||
call lv%set(amg_d_invt_solver_mold,info,pos=pos)
|
||||
case ('ILU','ILUT','MILU')
|
||||
call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
|
||||
if (info == 0) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
end if
|
||||
#ifdef HAVE_SLU_
|
||||
case ('SLU')
|
||||
case ('SLU')
|
||||
call lv%set(amg_d_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case ('MUMPS')
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef HAVE_SLUDIST_
|
||||
@@ -231,10 +243,10 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
@@ -249,7 +261,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
select case(ival)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
@@ -259,7 +271,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
@@ -286,13 +298,13 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
lv%parms%coarse_solve = amg_stringval(val)
|
||||
|
||||
case default
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -89,11 +89,11 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout)
|
||||
call lv%parms%descr(iout_,info,coarse=coarse)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%map%naggr)) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) ' Coarse Matrix: Global size: ', &
|
||||
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
write(iout_,*) ' Local matrix sizes: ', &
|
||||
& lv%map%naggr(:)
|
||||
& lv%linmap%naggr(:)
|
||||
write(iout_,*) ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
|
||||
@@ -108,17 +108,17 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
end if
|
||||
if (tprol_) then
|
||||
! Tentative prolongator is stored with column indices already
|
||||
! in global numbering, so only IVR is needed.
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
! This is not implemented yet.
|
||||
@@ -133,9 +133,9 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head)
|
||||
end if
|
||||
if (tprol_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
|
||||
@@ -63,7 +63,7 @@ subroutine amg_d_base_onelev_free(lv,info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%map%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
|
||||
@@ -0,0 +1,135 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_prol_v
|
||||
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_d_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
rrcv = vect_v%get_vect()
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
|
||||
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
end if
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
|
||||
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
|
||||
call psb_realloc(nrc,rsnd,info)
|
||||
call psb_rcv(ctxt,rsnd(1:nrl),idest)
|
||||
call tv%set_vect(rsnd)
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Prolongator with remap done '
|
||||
!!$ flush(0)
|
||||
!!$ call psb_barrier(ctxt)
|
||||
end block
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_map_prol_v
|
||||
|
||||
subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_prol_a
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
real(psb_dpk_), intent(inout) :: u(:)
|
||||
real(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_map_prol_a
|
||||
@@ -0,0 +1,129 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_rstr_v
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling not implemented yet '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_d_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
|
||||
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
rsnd = tv%get_vect()
|
||||
call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
|
||||
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
call vect_v%set_vect(rrcv)
|
||||
end if
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Restrictor with remap done '
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_map_rstr_v
|
||||
|
||||
subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_rstr_a
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
real(psb_dpk_), intent(inout) :: u(:)
|
||||
real(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_map_rstr_a
|
||||
@@ -53,7 +53,7 @@
|
||||
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
|
||||
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
|
||||
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
|
||||
! 4. Pack restrictor and prolongator into p%map
|
||||
! 4. Pack restrictor and prolongator into p%linmap
|
||||
! 5. Fix base_a and base_desc pointers.
|
||||
!
|
||||
!
|
||||
@@ -158,7 +158,7 @@ subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
|
||||
@@ -71,72 +71,81 @@ subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
!
|
||||
! At top level(s) I may be using
|
||||
! a context with less processes
|
||||
!
|
||||
if (me < 0) then
|
||||
!!$ write(0,*) 'onelevbld: I am excluded from this one '
|
||||
else
|
||||
!!$ write(0,*) me,' Going to build smoothers at this level '
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -62,6 +62,6 @@ subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
& call lv%ac%cscnv(info,mold=amold)
|
||||
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
|
||||
& .and. present(imold)) call lv%desc_ac%cnv(imold)
|
||||
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
|
||||
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_s_base_onelev_cnv
|
||||
|
||||
@@ -1,15 +1,15 @@
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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:
|
||||
@@ -21,7 +21,7 @@
|
||||
! 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
|
||||
@@ -33,10 +33,10 @@
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_csetc
|
||||
use amg_s_base_aggregator_mod
|
||||
@@ -49,6 +49,9 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
use amg_s_ilu_solver
|
||||
use amg_s_id_solver
|
||||
use amg_s_gs_solver
|
||||
use amg_s_ainv_solver
|
||||
use amg_s_invk_solver
|
||||
use amg_s_invt_solver
|
||||
#if defined(HAVE_SLU_)
|
||||
use amg_s_slu_solver
|
||||
#endif
|
||||
@@ -59,16 +62,16 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
integer(psb_ipk_) :: ival
|
||||
type(amg_s_base_smoother_type) :: amg_s_base_smoother_mold
|
||||
type(amg_s_jac_smoother_type) :: amg_s_jac_smoother_mold
|
||||
type(amg_s_l1_jac_smoother_type) :: amg_s_l1_jac_smoother_mold
|
||||
@@ -79,13 +82,16 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
type(amg_s_id_solver_type) :: amg_s_id_solver_mold
|
||||
type(amg_s_gs_solver_type) :: amg_s_gs_solver_mold
|
||||
type(amg_s_bwgs_solver_type) :: amg_s_bwgs_solver_mold
|
||||
type(amg_s_ainv_solver_type) :: amg_s_ainv_solver_mold
|
||||
type(amg_s_invk_solver_type) :: amg_s_invk_solver_mold
|
||||
type(amg_s_invt_solver_type) :: amg_s_invt_solver_mold
|
||||
#if defined(HAVE_SLU_)
|
||||
type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold
|
||||
#endif
|
||||
#if defined(HAVE_MUMPS_)
|
||||
type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
@@ -106,14 +112,14 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
|
||||
select case (psb_toupper(trim(what)))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NOPREC','NONE')
|
||||
call lv%set(amg_s_base_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('JAC','JACOBI')
|
||||
call lv%set(amg_s_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_diag_solver_mold,info,pos=pos)
|
||||
@@ -121,11 +127,11 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-JACOBI')
|
||||
call lv%set(amg_s_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BJAC')
|
||||
call lv%set(amg_s_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(amg_s_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
|
||||
@@ -154,67 +160,73 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(amg_s_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) call lv%sm%default()
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%default()
|
||||
end if
|
||||
|
||||
|
||||
|
||||
case('SUB_SOLVE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NONE','NOPREC','FACT_NONE')
|
||||
call lv%set(amg_s_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('DIAG')
|
||||
call lv%set(amg_s_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-DIAG')
|
||||
call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('GS','FGS','FWGS')
|
||||
call lv%set(amg_s_gs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_s_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('AINV')
|
||||
call lv%set(amg_s_ainv_solver_mold,info,pos=pos)
|
||||
case ('INVK')
|
||||
call lv%set(amg_s_invk_solver_mold,info,pos=pos)
|
||||
case ('INVT')
|
||||
call lv%set(amg_s_invt_solver_mold,info,pos=pos)
|
||||
case ('ILU','ILUT','MILU')
|
||||
call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
|
||||
if (info == 0) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
end if
|
||||
#ifdef HAVE_SLU_
|
||||
case ('SLU')
|
||||
case ('SLU')
|
||||
call lv%set(amg_s_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case ('MUMPS')
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_s_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
@@ -229,7 +241,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
select case(ival)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
@@ -239,7 +251,7 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
@@ -266,13 +278,13 @@ subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
lv%parms%coarse_solve = amg_stringval(val)
|
||||
|
||||
case default
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -89,11 +89,11 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout)
|
||||
call lv%parms%descr(iout_,info,coarse=coarse)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%map%naggr)) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) ' Coarse Matrix: Global size: ', &
|
||||
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
write(iout_,*) ' Local matrix sizes: ', &
|
||||
& lv%map%naggr(:)
|
||||
& lv%linmap%naggr(:)
|
||||
write(iout_,*) ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
|
||||
@@ -108,17 +108,17 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
end if
|
||||
if (tprol_) then
|
||||
! Tentative prolongator is stored with column indices already
|
||||
! in global numbering, so only IVR is needed.
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
! This is not implemented yet.
|
||||
@@ -133,9 +133,9 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head)
|
||||
end if
|
||||
if (tprol_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
|
||||
@@ -63,7 +63,7 @@ subroutine amg_s_base_onelev_free(lv,info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%map%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
|
||||
@@ -0,0 +1,135 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_prol_v
|
||||
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
real(psb_spk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_s_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
rrcv = vect_v%get_vect()
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
|
||||
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
end if
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
|
||||
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
|
||||
call psb_realloc(nrc,rsnd,info)
|
||||
call psb_rcv(ctxt,rsnd(1:nrl),idest)
|
||||
call tv%set_vect(rsnd)
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Prolongator with remap done '
|
||||
!!$ flush(0)
|
||||
!!$ call psb_barrier(ctxt)
|
||||
end block
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_map_prol_v
|
||||
|
||||
subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_prol_a
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
real(psb_spk_), intent(inout) :: u(:)
|
||||
real(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_map_prol_a
|
||||
@@ -0,0 +1,129 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_rstr_v
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling not implemented yet '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
real(psb_spk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_s_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
|
||||
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
rsnd = tv%get_vect()
|
||||
call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
|
||||
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
call vect_v%set_vect(rrcv)
|
||||
end if
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Restrictor with remap done '
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_map_rstr_v
|
||||
|
||||
subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_rstr_a
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
real(psb_spk_), intent(inout) :: u(:)
|
||||
real(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_map_rstr_a
|
||||
@@ -53,7 +53,7 @@
|
||||
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
|
||||
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
|
||||
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
|
||||
! 4. Pack restrictor and prolongator into p%map
|
||||
! 4. Pack restrictor and prolongator into p%linmap
|
||||
! 5. Fix base_a and base_desc pointers.
|
||||
!
|
||||
!
|
||||
@@ -158,7 +158,7 @@ subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
|
||||
@@ -71,72 +71,81 @@ subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
!
|
||||
! At top level(s) I may be using
|
||||
! a context with less processes
|
||||
!
|
||||
if (me < 0) then
|
||||
!!$ write(0,*) 'onelevbld: I am excluded from this one '
|
||||
else
|
||||
!!$ write(0,*) me,' Going to build smoothers at this level '
|
||||
if (.not.allocated(lv%sm)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
!! Error: should have called amg_dprecinit
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
lv%ac_nz_loc = lv%ac%get_nzeros()
|
||||
lv%ac_nz_tot = lv%ac_nz_loc
|
||||
select case(lv%parms%coarse_mat)
|
||||
case(amg_distr_mat_)
|
||||
call psb_sum(ctxt,lv%ac_nz_tot)
|
||||
case(amg_repl_mat_)
|
||||
! Do nothing
|
||||
case default
|
||||
! Should never get here
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Wrong lv%parms')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Calling mlprcbld at level ',i
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',izero,is_int_non_negative)
|
||||
|
||||
call lv%sm%build(lv%base_a,lv%base_desc,info)
|
||||
if (info == 0) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%build(lv%base_a,lv%base_desc,info)
|
||||
lv%sm2 => lv%sm2a
|
||||
else
|
||||
lv%sm2 => lv%sm
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (lv%sm%sv%is_global()) then
|
||||
if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then
|
||||
lv%parms%sweeps_pre = 1
|
||||
lv%parms%sweeps_post = 1
|
||||
if (me == 0) then
|
||||
write(debug_unit,*)
|
||||
if (present(ilv)) then
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" at level ',ilv
|
||||
write(debug_unit,*) ' is configured as a global solver '
|
||||
else
|
||||
write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),&
|
||||
& '" is configured as a global solver '
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
write(debug_unit,*) ' Pre and post sweeps at this level reset to 1'
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -62,6 +62,6 @@ subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
& call lv%ac%cscnv(info,mold=amold)
|
||||
if (info == psb_success_ .and. lv%desc_ac%is_ok() &
|
||||
& .and. present(imold)) call lv%desc_ac%cnv(imold)
|
||||
if (info == psb_success_) call lv%map%cnv(info,mold=amold,imold=imold)
|
||||
if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_z_base_onelev_cnv
|
||||
|
||||
@@ -1,15 +1,15 @@
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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:
|
||||
@@ -21,7 +21,7 @@
|
||||
! 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
|
||||
@@ -33,10 +33,10 @@
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_csetc
|
||||
use amg_z_base_aggregator_mod
|
||||
@@ -49,6 +49,9 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
use amg_z_ilu_solver
|
||||
use amg_z_id_solver
|
||||
use amg_z_gs_solver
|
||||
use amg_z_ainv_solver
|
||||
use amg_z_invk_solver
|
||||
use amg_z_invt_solver
|
||||
#if defined(HAVE_UMF_)
|
||||
use amg_z_umf_solver
|
||||
#endif
|
||||
@@ -65,16 +68,16 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
integer(psb_ipk_) :: ival
|
||||
type(amg_z_base_smoother_type) :: amg_z_base_smoother_mold
|
||||
type(amg_z_jac_smoother_type) :: amg_z_jac_smoother_mold
|
||||
type(amg_z_l1_jac_smoother_type) :: amg_z_l1_jac_smoother_mold
|
||||
@@ -85,6 +88,9 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
type(amg_z_id_solver_type) :: amg_z_id_solver_mold
|
||||
type(amg_z_gs_solver_type) :: amg_z_gs_solver_mold
|
||||
type(amg_z_bwgs_solver_type) :: amg_z_bwgs_solver_mold
|
||||
type(amg_z_ainv_solver_type) :: amg_z_ainv_solver_mold
|
||||
type(amg_z_invk_solver_type) :: amg_z_invk_solver_mold
|
||||
type(amg_z_invt_solver_type) :: amg_z_invt_solver_mold
|
||||
#if defined(HAVE_UMF_)
|
||||
type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold
|
||||
#endif
|
||||
@@ -97,7 +103,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
#if defined(HAVE_MUMPS_)
|
||||
type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
@@ -118,14 +124,14 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
|
||||
select case (psb_toupper(trim(what)))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NOPREC','NONE')
|
||||
call lv%set(amg_z_base_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('JAC','JACOBI')
|
||||
call lv%set(amg_z_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_diag_solver_mold,info,pos=pos)
|
||||
@@ -133,11 +139,11 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-JACOBI')
|
||||
call lv%set(amg_z_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BJAC')
|
||||
call lv%set(amg_z_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(amg_z_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
|
||||
@@ -166,59 +172,65 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(amg_z_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) call lv%sm%default()
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%default()
|
||||
end if
|
||||
|
||||
|
||||
|
||||
case('SUB_SOLVE')
|
||||
select case (psb_toupper(trim(val)))
|
||||
case ('NONE','NOPREC','FACT_NONE')
|
||||
call lv%set(amg_z_id_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('DIAG')
|
||||
call lv%set(amg_z_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('L1-DIAG')
|
||||
call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('GS','FGS','FWGS')
|
||||
call lv%set(amg_z_gs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_z_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
|
||||
case ('AINV')
|
||||
call lv%set(amg_z_ainv_solver_mold,info,pos=pos)
|
||||
case ('INVK')
|
||||
call lv%set(amg_z_invk_solver_mold,info,pos=pos)
|
||||
case ('INVT')
|
||||
call lv%set(amg_z_invt_solver_mold,info,pos=pos)
|
||||
case ('ILU','ILUT','MILU')
|
||||
call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
|
||||
if (info == 0) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
end if
|
||||
#ifdef HAVE_SLU_
|
||||
case ('SLU')
|
||||
case ('SLU')
|
||||
call lv%set(amg_z_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef HAVE_MUMPS_
|
||||
case ('MUMPS')
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_z_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef HAVE_SLUDIST_
|
||||
@@ -231,10 +243,10 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
@@ -249,7 +261,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
select case(ival)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
@@ -259,7 +271,7 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
@@ -286,13 +298,13 @@ subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
lv%parms%coarse_solve = amg_stringval(val)
|
||||
|
||||
case default
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
|
||||
@@ -89,11 +89,11 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout)
|
||||
call lv%parms%descr(iout_,info,coarse=coarse)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%map%naggr)) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) ' Coarse Matrix: Global size: ', &
|
||||
& sum((1_psb_lpk_*lv%map%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
& sum((1_psb_lpk_*lv%linmap%naggr(:))),' Nonzeros: ',lv%ac_nz_tot
|
||||
write(iout_,*) ' Local matrix sizes: ', &
|
||||
& lv%map%naggr(:)
|
||||
& lv%linmap%naggr(:)
|
||||
write(iout_,*) ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
|
||||
@@ -108,17 +108,17 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%map%p_desc_V%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc)
|
||||
end if
|
||||
if (tprol_) then
|
||||
! Tentative prolongator is stored with column indices already
|
||||
! in global numbering, so only IVR is needed.
|
||||
ivr = lv%map%p_desc_U%get_global_indices(owned=.false.)
|
||||
ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
! This is not implemented yet.
|
||||
@@ -133,9 +133,9 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%map%mat_U2V%print(fname,head=head)
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
call lv%map%mat_V2U%print(fname,head=head)
|
||||
call lv%linmap%mat_V2U%print(fname,head=head)
|
||||
end if
|
||||
if (tprol_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
|
||||
@@ -63,7 +63,7 @@ subroutine amg_z_base_onelev_free(lv,info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%map%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
|
||||
@@ -0,0 +1,135 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_prol_v
|
||||
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_z_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal()
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal()
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal()
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols()
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
rrcv = vect_v%get_vect()
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl
|
||||
call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
end if
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal()
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info
|
||||
!!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal()
|
||||
call psb_realloc(nrc,rsnd,info)
|
||||
call psb_rcv(ctxt,rsnd(1:nrl),idest)
|
||||
call tv%set_vect(rsnd)
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Prolongator with remap done '
|
||||
!!$ flush(0)
|
||||
!!$ call psb_barrier(ctxt)
|
||||
end block
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_map_prol_v
|
||||
|
||||
subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_prol_a
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
complex(psb_dpk_), intent(inout) :: u(:)
|
||||
complex(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_V2U(alpha,v,beta,u,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_map_prol_a
|
||||
@@ -0,0 +1,129 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_rstr_v
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
!!$ write(0,*) 'Remap handling not implemented yet '
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, nctxt
|
||||
integer(psb_ipk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_ipk_) :: me, np, rme, rnp
|
||||
complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_z_vect_type) :: tv
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
nctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(nctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context ',rme,rnp
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
!!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
|
||||
!!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
|
||||
nsrc = size(isrc)
|
||||
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
|
||||
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info)
|
||||
!!$ write(0,*) me,' Size of TV ',tv%get_nrows()
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
rsnd = tv%get_vect()
|
||||
call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
!!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows()
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv)
|
||||
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
|
||||
kp = kp + nrl
|
||||
end do
|
||||
call vect_v%set_vect(rrcv)
|
||||
end if
|
||||
end associate
|
||||
!!$ write(0,*) me, ' Restrictor with remap done '
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty)
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_map_rstr_v
|
||||
|
||||
subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_rstr_a
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
complex(psb_dpk_), intent(inout) :: u(:)
|
||||
complex(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap handling not implemented yet '
|
||||
else
|
||||
! Default transfer
|
||||
call lv%linmap%map_U2V(alpha,u,beta,v,info,&
|
||||
& work=work)
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_map_rstr_a
|
||||
@@ -53,7 +53,7 @@
|
||||
! 2. Call amg_Xaggrmat_asb to compute prolongator/restrictor/AC
|
||||
! 3. According to the choice of DIST/REPL for AC, build a descriptor DESC_AC,
|
||||
! and adjust the column numbering of AC/OP_PROL/OP_RESTR
|
||||
! 4. Pack restrictor and prolongator into p%map
|
||||
! 4. Pack restrictor and prolongator into p%linmap
|
||||
! 5. Fix base_a and base_desc pointers.
|
||||
!
|
||||
!
|
||||
@@ -158,7 +158,7 @@ subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%map,info)
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
|
||||
@@ -48,7 +48,6 @@ subroutine amg_c_ainv_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_c_ainv_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,8 +48,6 @@ subroutine amg_c_invk_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: me, np
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20), parameter :: name='amg_c_invk_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,7 +48,6 @@ subroutine amg_c_invt_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_c_invt_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -0,0 +1,271 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
! File: amg_c_rkr_solver_impl.f90
|
||||
!
|
||||
! This is the implementation file corresponding to amg_c_rkr_solver_mod.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_c_rkr_solver, amg_protect_name => amg_c_rkr_solver_bld
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(psb_cspmat_type), intent(inout), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_cspmat_type), intent(in), target, optional :: b
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
|
||||
integer(psb_lpk_) :: lnr
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt, l_ctxt
|
||||
character(len=20) :: name='c_rkr_solver_bld', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call sv%prec%free(info)
|
||||
|
||||
if (sv%global) then
|
||||
call sv%prec%init(ctxt,sv%kprec,info)
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call sv%prec%hierarchy_build(a,desc_a,info)
|
||||
call sv%prec%smoothers_build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
sv%a => a
|
||||
else
|
||||
call psb_init(l_ctxt,np=1_psb_ipk_,basectxt=ctxt,ids=(/me/))
|
||||
n_row = desc_a%get_local_rows()
|
||||
lnr = n_row
|
||||
call psb_cdall(l_ctxt,sv%desc_local,info,mg=lnr,repl=.true.)
|
||||
call psb_cdasb(sv%desc_local,info)
|
||||
call sv%prec%init(l_ctxt,sv%kprec,info)
|
||||
!This is a gigantic kludge, to be revised
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call a%csclip(sv%a_local,info,jmax=n_row)
|
||||
call sv%prec%hierarchy_build(sv%a_local,sv%desc_local,info)
|
||||
call sv%prec%smoothers_build(sv%a_local,sv%desc_local,info,amold=amold,vmold=vmold)
|
||||
call psb_geall(sv%x_local,sv%desc_local,info)
|
||||
call sv%x_local%zero()
|
||||
call psb_geasb(sv%x_local,sv%desc_local,info,mold=vmold)
|
||||
call psb_geall(sv%z_local,sv%desc_local,info)
|
||||
call sv%z_local%zero()
|
||||
call psb_geasb(sv%z_local,sv%desc_local,info,mold=vmold)
|
||||
end if
|
||||
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='inner precbld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_c_rkr_solver_bld
|
||||
|
||||
subroutine amg_c_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_krylov_mod
|
||||
use amg_c_rkr_solver, amg_protect_name => amg_c_rkr_solver_apply_vect
|
||||
|
||||
Implicit None
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_c_vect_type),intent(inout) :: x
|
||||
type(psb_c_vect_type),intent(inout) :: y
|
||||
complex(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_c_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_c_vect_type),intent(inout), optional :: initu
|
||||
|
||||
type(psb_c_vect_type) :: z
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='c_rkr_solver_apply_v', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
if (sv%global) then
|
||||
call psb_geall(z,desc_data,info)
|
||||
call z%zero()
|
||||
call psb_geasb(z,desc_data,info,mold=x%v)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' norms ',&
|
||||
& psb_genrm2(x,desc_data,info),psb_genrm2(y,desc_data,info),&
|
||||
& psb_genrm2(z,desc_data,info)
|
||||
|
||||
call psb_krylov(sv%method,sv%a,sv%prec,x,z,sv%eps,&
|
||||
& desc_data,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
!!$ call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
else
|
||||
call psb_geaxpby(cone,x,czero,sv%x_local,sv%desc_local,info)
|
||||
call psb_krylov(sv%method,sv%a_local,sv%prec,sv%x_local,sv%z_local,sv%eps,&
|
||||
& sv%desc_local,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
call psb_geaxpby(alpha,sv%z_local,beta,y,sv%desc_local,info)
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_c_rkr_solver_apply_vect
|
||||
|
||||
|
||||
subroutine amg_c_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
use psb_base_mod
|
||||
use amg_c_rkr_solver, amg_protect_name => amg_c_rkr_solver_apply
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_c_rkr_solver_type), intent(inout) :: sv
|
||||
complex(psb_spk_),intent(inout) :: x(:)
|
||||
complex(psb_spk_),intent(inout) :: y(:)
|
||||
complex(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_spk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
complex(psb_spk_),intent(inout), optional :: initu(:)
|
||||
complex(psb_spk_), allocatable :: z(:)
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='c_rkr_solver_apply', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call psb_geasb(z,desc_data,info,scratch=.true.)
|
||||
|
||||
call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_c_rkr_solver_apply
|
||||
@@ -48,7 +48,6 @@ subroutine amg_d_ainv_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_d_ainv_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,8 +48,6 @@ subroutine amg_d_invk_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: me, np
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20), parameter :: name='amg_d_invk_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,7 +48,6 @@ subroutine amg_d_invt_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_d_invt_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -0,0 +1,271 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
! File: amg_d_rkr_solver_impl.f90
|
||||
!
|
||||
! This is the implementation file corresponding to amg_d_rkr_solver_mod.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_d_rkr_solver, amg_protect_name => amg_d_rkr_solver_bld
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(psb_dspmat_type), intent(inout), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_dspmat_type), intent(in), target, optional :: b
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
|
||||
integer(psb_lpk_) :: lnr
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt, l_ctxt
|
||||
character(len=20) :: name='d_rkr_solver_bld', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call sv%prec%free(info)
|
||||
|
||||
if (sv%global) then
|
||||
call sv%prec%init(ctxt,sv%kprec,info)
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call sv%prec%hierarchy_build(a,desc_a,info)
|
||||
call sv%prec%smoothers_build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
sv%a => a
|
||||
else
|
||||
call psb_init(l_ctxt,np=1_psb_ipk_,basectxt=ctxt,ids=(/me/))
|
||||
n_row = desc_a%get_local_rows()
|
||||
lnr = n_row
|
||||
call psb_cdall(l_ctxt,sv%desc_local,info,mg=lnr,repl=.true.)
|
||||
call psb_cdasb(sv%desc_local,info)
|
||||
call sv%prec%init(l_ctxt,sv%kprec,info)
|
||||
!This is a gigantic kludge, to be revised
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call a%csclip(sv%a_local,info,jmax=n_row)
|
||||
call sv%prec%hierarchy_build(sv%a_local,sv%desc_local,info)
|
||||
call sv%prec%smoothers_build(sv%a_local,sv%desc_local,info,amold=amold,vmold=vmold)
|
||||
call psb_geall(sv%x_local,sv%desc_local,info)
|
||||
call sv%x_local%zero()
|
||||
call psb_geasb(sv%x_local,sv%desc_local,info,mold=vmold)
|
||||
call psb_geall(sv%z_local,sv%desc_local,info)
|
||||
call sv%z_local%zero()
|
||||
call psb_geasb(sv%z_local,sv%desc_local,info,mold=vmold)
|
||||
end if
|
||||
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='inner precbld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_d_rkr_solver_bld
|
||||
|
||||
subroutine amg_d_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_krylov_mod
|
||||
use amg_d_rkr_solver, amg_protect_name => amg_d_rkr_solver_apply_vect
|
||||
|
||||
Implicit None
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_d_vect_type),intent(inout) :: x
|
||||
type(psb_d_vect_type),intent(inout) :: y
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_d_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_d_vect_type),intent(inout), optional :: initu
|
||||
|
||||
type(psb_d_vect_type) :: z
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='d_rkr_solver_apply_v', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
if (sv%global) then
|
||||
call psb_geall(z,desc_data,info)
|
||||
call z%zero()
|
||||
call psb_geasb(z,desc_data,info,mold=x%v)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' norms ',&
|
||||
& psb_genrm2(x,desc_data,info),psb_genrm2(y,desc_data,info),&
|
||||
& psb_genrm2(z,desc_data,info)
|
||||
|
||||
call psb_krylov(sv%method,sv%a,sv%prec,x,z,sv%eps,&
|
||||
& desc_data,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
!!$ call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
else
|
||||
call psb_geaxpby(done,x,dzero,sv%x_local,sv%desc_local,info)
|
||||
call psb_krylov(sv%method,sv%a_local,sv%prec,sv%x_local,sv%z_local,sv%eps,&
|
||||
& sv%desc_local,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
call psb_geaxpby(alpha,sv%z_local,beta,y,sv%desc_local,info)
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_d_rkr_solver_apply_vect
|
||||
|
||||
|
||||
subroutine amg_d_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
use psb_base_mod
|
||||
use amg_d_rkr_solver, amg_protect_name => amg_d_rkr_solver_apply
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_d_rkr_solver_type), intent(inout) :: sv
|
||||
real(psb_dpk_),intent(inout) :: x(:)
|
||||
real(psb_dpk_),intent(inout) :: y(:)
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
real(psb_dpk_),intent(inout), optional :: initu(:)
|
||||
real(psb_dpk_), allocatable :: z(:)
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='d_rkr_solver_apply', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call psb_geasb(z,desc_data,info,scratch=.true.)
|
||||
|
||||
call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_d_rkr_solver_apply
|
||||
@@ -48,7 +48,6 @@ subroutine amg_s_ainv_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_s_ainv_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,8 +48,6 @@ subroutine amg_s_invk_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: me, np
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20), parameter :: name='amg_s_invk_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,7 +48,6 @@ subroutine amg_s_invt_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_s_invt_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -0,0 +1,271 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
! File: amg_s_rkr_solver_impl.f90
|
||||
!
|
||||
! This is the implementation file corresponding to amg_s_rkr_solver_mod.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_rkr_solver, amg_protect_name => amg_s_rkr_solver_bld
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(psb_sspmat_type), intent(inout), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_sspmat_type), intent(in), target, optional :: b
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
|
||||
integer(psb_lpk_) :: lnr
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt, l_ctxt
|
||||
character(len=20) :: name='s_rkr_solver_bld', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call sv%prec%free(info)
|
||||
|
||||
if (sv%global) then
|
||||
call sv%prec%init(ctxt,sv%kprec,info)
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call sv%prec%hierarchy_build(a,desc_a,info)
|
||||
call sv%prec%smoothers_build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
sv%a => a
|
||||
else
|
||||
call psb_init(l_ctxt,np=1_psb_ipk_,basectxt=ctxt,ids=(/me/))
|
||||
n_row = desc_a%get_local_rows()
|
||||
lnr = n_row
|
||||
call psb_cdall(l_ctxt,sv%desc_local,info,mg=lnr,repl=.true.)
|
||||
call psb_cdasb(sv%desc_local,info)
|
||||
call sv%prec%init(l_ctxt,sv%kprec,info)
|
||||
!This is a gigantic kludge, to be revised
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call a%csclip(sv%a_local,info,jmax=n_row)
|
||||
call sv%prec%hierarchy_build(sv%a_local,sv%desc_local,info)
|
||||
call sv%prec%smoothers_build(sv%a_local,sv%desc_local,info,amold=amold,vmold=vmold)
|
||||
call psb_geall(sv%x_local,sv%desc_local,info)
|
||||
call sv%x_local%zero()
|
||||
call psb_geasb(sv%x_local,sv%desc_local,info,mold=vmold)
|
||||
call psb_geall(sv%z_local,sv%desc_local,info)
|
||||
call sv%z_local%zero()
|
||||
call psb_geasb(sv%z_local,sv%desc_local,info,mold=vmold)
|
||||
end if
|
||||
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='inner precbld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_rkr_solver_bld
|
||||
|
||||
subroutine amg_s_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_krylov_mod
|
||||
use amg_s_rkr_solver, amg_protect_name => amg_s_rkr_solver_apply_vect
|
||||
|
||||
Implicit None
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_s_vect_type),intent(inout) :: x
|
||||
type(psb_s_vect_type),intent(inout) :: y
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_s_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_s_vect_type),intent(inout), optional :: initu
|
||||
|
||||
type(psb_s_vect_type) :: z
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='s_rkr_solver_apply_v', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
if (sv%global) then
|
||||
call psb_geall(z,desc_data,info)
|
||||
call z%zero()
|
||||
call psb_geasb(z,desc_data,info,mold=x%v)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' norms ',&
|
||||
& psb_genrm2(x,desc_data,info),psb_genrm2(y,desc_data,info),&
|
||||
& psb_genrm2(z,desc_data,info)
|
||||
|
||||
call psb_krylov(sv%method,sv%a,sv%prec,x,z,sv%eps,&
|
||||
& desc_data,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
!!$ call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
else
|
||||
call psb_geaxpby(sone,x,szero,sv%x_local,sv%desc_local,info)
|
||||
call psb_krylov(sv%method,sv%a_local,sv%prec,sv%x_local,sv%z_local,sv%eps,&
|
||||
& sv%desc_local,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
call psb_geaxpby(alpha,sv%z_local,beta,y,sv%desc_local,info)
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_rkr_solver_apply_vect
|
||||
|
||||
|
||||
subroutine amg_s_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
use psb_base_mod
|
||||
use amg_s_rkr_solver, amg_protect_name => amg_s_rkr_solver_apply
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_rkr_solver_type), intent(inout) :: sv
|
||||
real(psb_spk_),intent(inout) :: x(:)
|
||||
real(psb_spk_),intent(inout) :: y(:)
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
real(psb_spk_),intent(inout), optional :: initu(:)
|
||||
real(psb_spk_), allocatable :: z(:)
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='s_rkr_solver_apply', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call psb_geasb(z,desc_data,info,scratch=.true.)
|
||||
|
||||
call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_rkr_solver_apply
|
||||
@@ -48,7 +48,6 @@ subroutine amg_z_ainv_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_z_ainv_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,8 +48,6 @@ subroutine amg_z_invk_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: me, np
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20), parameter :: name='amg_z_invk_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -48,7 +48,6 @@ subroutine amg_z_invt_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='amg_z_invt_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
|
||||
@@ -0,0 +1,271 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2020
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
! File: amg_z_rkr_solver_impl.f90
|
||||
!
|
||||
! This is the implementation file corresponding to amg_z_rkr_solver_mod.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_rkr_solver_bld(a,desc_a,sv,info,b,amold,vmold)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_z_rkr_solver, amg_protect_name => amg_z_rkr_solver_bld
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(psb_zspmat_type), intent(inout), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_zspmat_type), intent(in), target, optional :: b
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota
|
||||
integer(psb_lpk_) :: lnr
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt, l_ctxt
|
||||
character(len=20) :: name='z_rkr_solver_bld', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call sv%prec%free(info)
|
||||
|
||||
if (sv%global) then
|
||||
call sv%prec%init(ctxt,sv%kprec,info)
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call sv%prec%hierarchy_build(a,desc_a,info)
|
||||
call sv%prec%smoothers_build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
sv%a => a
|
||||
else
|
||||
call psb_init(l_ctxt,np=1_psb_ipk_,basectxt=ctxt,ids=(/me/))
|
||||
n_row = desc_a%get_local_rows()
|
||||
lnr = n_row
|
||||
call psb_cdall(l_ctxt,sv%desc_local,info,mg=lnr,repl=.true.)
|
||||
call psb_cdasb(sv%desc_local,info)
|
||||
call sv%prec%init(l_ctxt,sv%kprec,info)
|
||||
!This is a gigantic kludge, to be revised
|
||||
if (sv%i_sub_solve>0) then
|
||||
call sv%prec%set('sub_solve',sv%i_sub_solve,info)
|
||||
else
|
||||
call sv%prec%set('sub_solve',sv%sub_solve,info)
|
||||
end if
|
||||
call sv%prec%set('sub_fillin',sv%fillin,info)
|
||||
call a%csclip(sv%a_local,info,jmax=n_row)
|
||||
call sv%prec%hierarchy_build(sv%a_local,sv%desc_local,info)
|
||||
call sv%prec%smoothers_build(sv%a_local,sv%desc_local,info,amold=amold,vmold=vmold)
|
||||
call psb_geall(sv%x_local,sv%desc_local,info)
|
||||
call sv%x_local%zero()
|
||||
call psb_geasb(sv%x_local,sv%desc_local,info,mold=vmold)
|
||||
call psb_geall(sv%z_local,sv%desc_local,info)
|
||||
call sv%z_local%zero()
|
||||
call psb_geasb(sv%z_local,sv%desc_local,info,mold=vmold)
|
||||
end if
|
||||
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
ch_err='inner precbld'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_z_rkr_solver_bld
|
||||
|
||||
subroutine amg_z_rkr_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_krylov_mod
|
||||
use amg_z_rkr_solver, amg_protect_name => amg_z_rkr_solver_apply_vect
|
||||
|
||||
Implicit None
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
type(psb_z_vect_type),intent(inout) :: x
|
||||
type(psb_z_vect_type),intent(inout) :: y
|
||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_z_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_z_vect_type),intent(inout), optional :: initu
|
||||
|
||||
type(psb_z_vect_type) :: z
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='z_rkr_solver_apply_v', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
if (sv%global) then
|
||||
call psb_geall(z,desc_data,info)
|
||||
call z%zero()
|
||||
call psb_geasb(z,desc_data,info,mold=x%v)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' norms ',&
|
||||
& psb_genrm2(x,desc_data,info),psb_genrm2(y,desc_data,info),&
|
||||
& psb_genrm2(z,desc_data,info)
|
||||
|
||||
call psb_krylov(sv%method,sv%a,sv%prec,x,z,sv%eps,&
|
||||
& desc_data,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
!!$ call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
else
|
||||
call psb_geaxpby(zone,x,zzero,sv%x_local,sv%desc_local,info)
|
||||
call psb_krylov(sv%method,sv%a_local,sv%prec,sv%x_local,sv%z_local,sv%eps,&
|
||||
& sv%desc_local,info,itmax=sv%itmax,itrace=sv%itrace,&
|
||||
& istop=sv%istopc,irst=sv%irst)
|
||||
call psb_geaxpby(alpha,sv%z_local,beta,y,sv%desc_local,info)
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_z_rkr_solver_apply_vect
|
||||
|
||||
|
||||
subroutine amg_z_rkr_solver_apply(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,info,init,initu)
|
||||
use psb_base_mod
|
||||
use amg_z_rkr_solver, amg_protect_name => amg_z_rkr_solver_apply
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_z_rkr_solver_type), intent(inout) :: sv
|
||||
complex(psb_dpk_),intent(inout) :: x(:)
|
||||
complex(psb_dpk_),intent(inout) :: y(:)
|
||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_dpk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
complex(psb_dpk_),intent(inout), optional :: initu(:)
|
||||
complex(psb_dpk_), allocatable :: z(:)
|
||||
integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
character(len=20) :: name='z_rkr_solver_apply', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
call psb_geasb(z,desc_data,info,scratch=.true.)
|
||||
|
||||
call sv%prec%apply(x,z,desc_data,info,trans=trans,work=work)
|
||||
|
||||
call psb_geaxpby(alpha,z,beta,y,desc_data,info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_z_rkr_solver_apply
|
||||
@@ -268,6 +268,49 @@ contains
|
||||
! the set of global indices it owns.
|
||||
!
|
||||
call psb_cdall(ctxt,desc_a,info,vl=myidx)
|
||||
|
||||
!
|
||||
! Specify process topology
|
||||
!
|
||||
block
|
||||
!
|
||||
! Use adjcncy methods
|
||||
!
|
||||
integer(psb_mpk_), allocatable :: neighbours(:)
|
||||
integer(psb_mpk_) :: cnt
|
||||
logical, parameter :: debug_adj=.true.
|
||||
if (debug_adj.and.(np > 1)) then
|
||||
cnt = 0
|
||||
allocate(neighbours(np))
|
||||
if (iamx < npx-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx+1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy < npy-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy+1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz < npz-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz+1,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamx >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx-1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy-1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz-1,npx,npy,npz,base=0)
|
||||
end if
|
||||
call psb_realloc(cnt, neighbours,info)
|
||||
call desc_a%set_p_adjcncy(neighbours)
|
||||
!write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy()
|
||||
end if
|
||||
end block
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) iam, 'Initialization error: should not get here'
|
||||
|
||||
@@ -268,6 +268,49 @@ contains
|
||||
! the set of global indices it owns.
|
||||
!
|
||||
call psb_cdall(ctxt,desc_a,info,vl=myidx)
|
||||
|
||||
!
|
||||
! Specify process topology
|
||||
!
|
||||
block
|
||||
!
|
||||
! Use adjcncy methods
|
||||
!
|
||||
integer(psb_mpk_), allocatable :: neighbours(:)
|
||||
integer(psb_mpk_) :: cnt
|
||||
logical, parameter :: debug_adj=.true.
|
||||
if (debug_adj.and.(np > 1)) then
|
||||
cnt = 0
|
||||
allocate(neighbours(np))
|
||||
if (iamx < npx-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx+1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy < npy-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy+1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz < npz-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz+1,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamx >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx-1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy-1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz-1,npx,npy,npz,base=0)
|
||||
end if
|
||||
call psb_realloc(cnt, neighbours,info)
|
||||
call desc_a%set_p_adjcncy(neighbours)
|
||||
!write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy()
|
||||
end if
|
||||
end block
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) iam, 'Initialization error: should not get here'
|
||||
|
||||
@@ -43,7 +43,7 @@ check: all
|
||||
|
||||
|
||||
clean:
|
||||
/bin/rm -f data_input.o amg_d_pde3d.o amg_s_pde3d.o amg_d_pde2d.o amg_s_pde2d.o *$(.mod)\
|
||||
/bin/rm -f data_input.o *.o *$(.mod)\
|
||||
$(EXEDIR)/mld_d_pde3d $(EXEDIR)/mld_s_pde3d $(EXEDIR)/mld_d_pde2d $(EXEDIR)/mld_s_pde2d
|
||||
|
||||
verycleanlib:
|
||||
|
||||
@@ -268,6 +268,49 @@ contains
|
||||
!
|
||||
call psb_cdall(ctxt,desc_a,info,vl=myidx)
|
||||
|
||||
!
|
||||
! Specify process topology
|
||||
!
|
||||
block
|
||||
!
|
||||
! Use adjcncy methods
|
||||
!
|
||||
integer(psb_mpk_), allocatable :: neighbours(:)
|
||||
integer(psb_mpk_) :: cnt
|
||||
logical, parameter :: debug_adj=.true.
|
||||
if (debug_adj.and.(np > 1)) then
|
||||
cnt = 0
|
||||
allocate(neighbours(np))
|
||||
if (iamx < npx-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx+1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy < npy-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy+1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz < npz-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz+1,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamx >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx-1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy-1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz-1,npx,npy,npz,base=0)
|
||||
end if
|
||||
call psb_realloc(cnt, neighbours,info)
|
||||
call desc_a%set_p_adjcncy(neighbours)
|
||||
!write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy()
|
||||
end if
|
||||
end block
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) iam, 'Initialization error: should not get here'
|
||||
info = -1
|
||||
@@ -674,6 +717,41 @@ contains
|
||||
!
|
||||
call psb_cdall(ctxt,desc_a,info,vl=myidx)
|
||||
|
||||
!
|
||||
! Specify process topology
|
||||
!
|
||||
block
|
||||
!
|
||||
! Use adjcncy methods
|
||||
!
|
||||
integer(psb_mpk_), allocatable :: neighbours(:)
|
||||
integer(psb_mpk_) :: cnt
|
||||
logical, parameter :: debug_adj=.true.
|
||||
if (debug_adj.and.(np > 1)) then
|
||||
cnt = 0
|
||||
allocate(neighbours(np))
|
||||
if (iamx < npx-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx+1,iamy,npx,npy,base=0)
|
||||
end if
|
||||
if (iamy < npy-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy+1,npx,npy,base=0)
|
||||
end if
|
||||
if (iamx >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx-1,iamy,npx,npy,base=0)
|
||||
end if
|
||||
if (iamy >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy-1,npx,npy,base=0)
|
||||
end if
|
||||
call psb_realloc(cnt, neighbours,info)
|
||||
call desc_a%set_p_adjcncy(neighbours)
|
||||
!write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy()
|
||||
end if
|
||||
end block
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) iam, 'Initialization error: should not get here'
|
||||
info = -1
|
||||
|
||||
@@ -73,8 +73,6 @@ program amg_d_pde2d
|
||||
use amg_d_pde2d_exp_mod
|
||||
use amg_d_pde2d_box_mod
|
||||
use amg_d_genpde_mod
|
||||
use amg_ainv_mod
|
||||
use amg_d_ilu_solver
|
||||
implicit none
|
||||
|
||||
! input parameters
|
||||
@@ -114,9 +112,6 @@ program amg_d_pde2d
|
||||
type(solverdata) :: s_choice
|
||||
|
||||
! preconditioner data
|
||||
type(amg_d_invt_solver_type) :: invtsv
|
||||
type(amg_d_invk_solver_type) :: invksv
|
||||
type(amg_d_ainv_solver_type) :: ainvsv
|
||||
type precdata
|
||||
|
||||
! preconditioner type
|
||||
@@ -311,11 +306,11 @@ program amg_d_pde2d
|
||||
call prec%set('sub_prol', p_choice%prol, info)
|
||||
select case(trim(psb_toupper(p_choice%solve)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
@@ -338,12 +333,12 @@ program amg_d_pde2d
|
||||
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
|
||||
select case(trim(psb_toupper(p_choice%solve2)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info, pos='post')
|
||||
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
|
||||
end select
|
||||
|
||||
@@ -74,8 +74,6 @@ program amg_d_pde3d
|
||||
use amg_d_pde3d_exp_mod
|
||||
use amg_d_pde3d_gauss_mod
|
||||
use amg_d_genpde_mod
|
||||
use amg_ainv_mod
|
||||
use amg_d_ilu_solver
|
||||
implicit none
|
||||
|
||||
! input parameters
|
||||
@@ -115,9 +113,6 @@ program amg_d_pde3d
|
||||
type(solverdata) :: s_choice
|
||||
|
||||
! preconditioner data
|
||||
type(amg_d_invt_solver_type) :: invtsv
|
||||
type(amg_d_invk_solver_type) :: invksv
|
||||
type(amg_d_ainv_solver_type) :: ainvsv
|
||||
type precdata
|
||||
|
||||
! preconditioner type
|
||||
@@ -315,11 +310,11 @@ program amg_d_pde3d
|
||||
call prec%set('sub_prol', p_choice%prol, info)
|
||||
select case(trim(psb_toupper(p_choice%solve)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
@@ -342,12 +337,12 @@ program amg_d_pde3d
|
||||
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
|
||||
select case(trim(psb_toupper(p_choice%solve2)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info, pos='post')
|
||||
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
|
||||
end select
|
||||
|
||||
@@ -268,6 +268,49 @@ contains
|
||||
!
|
||||
call psb_cdall(ctxt,desc_a,info,vl=myidx)
|
||||
|
||||
!
|
||||
! Specify process topology
|
||||
!
|
||||
block
|
||||
!
|
||||
! Use adjcncy methods
|
||||
!
|
||||
integer(psb_mpk_), allocatable :: neighbours(:)
|
||||
integer(psb_mpk_) :: cnt
|
||||
logical, parameter :: debug_adj=.true.
|
||||
if (debug_adj.and.(np > 1)) then
|
||||
cnt = 0
|
||||
allocate(neighbours(np))
|
||||
if (iamx < npx-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx+1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy < npy-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy+1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz < npz-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz+1,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamx >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx-1,iamy,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamy >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy-1,iamz,npx,npy,npz,base=0)
|
||||
end if
|
||||
if (iamz >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy,iamz-1,npx,npy,npz,base=0)
|
||||
end if
|
||||
call psb_realloc(cnt, neighbours,info)
|
||||
call desc_a%set_p_adjcncy(neighbours)
|
||||
!write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy()
|
||||
end if
|
||||
end block
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) iam, 'Initialization error: should not get here'
|
||||
info = -1
|
||||
@@ -674,6 +717,41 @@ contains
|
||||
!
|
||||
call psb_cdall(ctxt,desc_a,info,vl=myidx)
|
||||
|
||||
!
|
||||
! Specify process topology
|
||||
!
|
||||
block
|
||||
!
|
||||
! Use adjcncy methods
|
||||
!
|
||||
integer(psb_mpk_), allocatable :: neighbours(:)
|
||||
integer(psb_mpk_) :: cnt
|
||||
logical, parameter :: debug_adj=.true.
|
||||
if (debug_adj.and.(np > 1)) then
|
||||
cnt = 0
|
||||
allocate(neighbours(np))
|
||||
if (iamx < npx-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx+1,iamy,npx,npy,base=0)
|
||||
end if
|
||||
if (iamy < npy-1) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy+1,npx,npy,base=0)
|
||||
end if
|
||||
if (iamx >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx-1,iamy,npx,npy,base=0)
|
||||
end if
|
||||
if (iamy >0) then
|
||||
cnt = cnt + 1
|
||||
call ijk2idx(neighbours(cnt),iamx,iamy-1,npx,npy,base=0)
|
||||
end if
|
||||
call psb_realloc(cnt, neighbours,info)
|
||||
call desc_a%set_p_adjcncy(neighbours)
|
||||
!write(0,*) iam,' Check on neighbours: ',desc_a%get_p_adjcncy()
|
||||
end if
|
||||
end block
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) iam, 'Initialization error: should not get here'
|
||||
info = -1
|
||||
|
||||
@@ -73,8 +73,6 @@ program amg_s_pde2d
|
||||
use amg_s_pde2d_exp_mod
|
||||
use amg_s_pde2d_box_mod
|
||||
use amg_s_genpde_mod
|
||||
use amg_ainv_mod
|
||||
use amg_s_ilu_solver
|
||||
implicit none
|
||||
|
||||
! input parameters
|
||||
@@ -114,9 +112,6 @@ program amg_s_pde2d
|
||||
type(solverdata) :: s_choice
|
||||
|
||||
! preconditioner data
|
||||
type(amg_s_invt_solver_type) :: invtsv
|
||||
type(amg_s_invk_solver_type) :: invksv
|
||||
type(amg_s_ainv_solver_type) :: ainvsv
|
||||
type precdata
|
||||
|
||||
! preconditioner type
|
||||
@@ -311,11 +306,11 @@ program amg_s_pde2d
|
||||
call prec%set('sub_prol', p_choice%prol, info)
|
||||
select case(trim(psb_toupper(p_choice%solve)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
@@ -338,12 +333,12 @@ program amg_s_pde2d
|
||||
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
|
||||
select case(trim(psb_toupper(p_choice%solve2)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info, pos='post')
|
||||
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
|
||||
end select
|
||||
|
||||
@@ -74,8 +74,6 @@ program amg_s_pde3d
|
||||
use amg_s_pde3d_exp_mod
|
||||
use amg_s_pde3d_gauss_mod
|
||||
use amg_s_genpde_mod
|
||||
use amg_ainv_mod
|
||||
use amg_s_ilu_solver
|
||||
implicit none
|
||||
|
||||
! input parameters
|
||||
@@ -115,9 +113,6 @@ program amg_s_pde3d
|
||||
type(solverdata) :: s_choice
|
||||
|
||||
! preconditioner data
|
||||
type(amg_s_invt_solver_type) :: invtsv
|
||||
type(amg_s_invk_solver_type) :: invksv
|
||||
type(amg_s_ainv_solver_type) :: ainvsv
|
||||
type precdata
|
||||
|
||||
! preconditioner type
|
||||
@@ -315,11 +310,11 @@ program amg_s_pde3d
|
||||
call prec%set('sub_prol', p_choice%prol, info)
|
||||
select case(trim(psb_toupper(p_choice%solve)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info)
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
@@ -342,12 +337,12 @@ program amg_s_pde3d
|
||||
call prec%set('sub_prol', p_choice%prol2, info,pos='post')
|
||||
select case(trim(psb_toupper(p_choice%solve2)))
|
||||
case('INVK')
|
||||
call prec%set(invksv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('INVT')
|
||||
call prec%set(invtsv, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
case('AINV')
|
||||
call prec%set(ainvsv, info, pos='post')
|
||||
call prec%set('ainv_alg', p_choice%variant2, info, pos='post')
|
||||
call prec%set('sub_solve', p_choice%solve, info)
|
||||
call prec%set('ainv_alg', p_choice%variant, info)
|
||||
case default
|
||||
call prec%set('sub_solve', p_choice%solve2, info, pos='post')
|
||||
end select
|
||||
|
||||
Reference in New Issue
Block a user