mirror of
https://github.com/sfilippone/amg4psblas.git
synced 2026-10-09 15:41:46 +00:00
Compare commits
22
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 sfilippone
|
c8a70f93a9 | ||
|
sfilippone
|
393bff19fb | ||
 sfilippone
|
d2122bf4b6 | ||
 Stack-1
|
eee27acfc1 | ||
|
sfilippone
|
72a731ca78 | ||
|
sfilippone
|
243be49a82 | ||
|
sfilippone
|
dccb20652d | ||
|
sfilippone
|
5433634f7d | ||
|
sfilippone
|
4cfd8c6d91 | ||
|
sfilippone
|
83b53884b7 | ||
|
sfilippone
|
e944da5bf7 | ||
|
sfilippone
|
a3e1be46ee | ||
|
sfilippone
|
3343b039e6 | ||
|
sfilippone
|
5c055170e7 | ||
|
sfilippone
|
0814492adc | ||
|
sfilippone
|
1ae3cc135f | ||
|
sfilippone
|
246992cb65 | ||
|
sfilippone
|
01cc7ada88 | ||
|
sfilippone
|
693eab66cb | ||
|
sfilippone
|
1a2ec161d7 | ||
|
sfilippone
|
4642c857d1 | ||
|
sfilippone
|
c8d065fa55 |
+134
-378
@@ -252,9 +252,7 @@ module amg_c_onelev_mod
|
||||
& c_base_onelev_free_wrk
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
import :: psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lcspmat_type, psb_lpk_
|
||||
import :: amg_c_onelev_type
|
||||
module subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), intent(inout), target :: lv
|
||||
type(psb_cspmat_type), intent(in) :: a
|
||||
@@ -266,10 +264,7 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
import :: psb_c_base_sparse_mat, psb_c_base_vect_type, &
|
||||
& psb_i_base_vect_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -281,10 +276,7 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
@@ -297,10 +289,8 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity, prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
@@ -314,10 +304,7 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_c_onelev_type, psb_c_base_vect_type, psb_spk_, &
|
||||
& psb_c_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
|
||||
! Arguments
|
||||
module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: amold
|
||||
@@ -327,48 +314,32 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_free(lv,info)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_c_base_onelev_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_free_smoothers(lv,info)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_c_base_onelev_free_smoothers
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_check(lv,info)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_c_base_onelev_check
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
|
||||
import :: psb_spk_, amg_c_onelev_type, amg_c_base_smoother_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_c_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -377,12 +348,8 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
|
||||
import :: psb_spk_, amg_c_onelev_type, amg_c_base_solver_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_c_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -391,12 +358,8 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_setag(lv,val,info,pos)
|
||||
import :: psb_spk_, amg_c_onelev_type, amg_c_base_aggregator_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_setag(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_c_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -405,13 +368,8 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
@@ -422,12 +380,8 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module 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
|
||||
character(len=*), intent(in) :: val
|
||||
@@ -438,12 +392,8 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
@@ -454,11 +404,8 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
module subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
& solver,tprol,global_num)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
implicit none
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
@@ -469,8 +416,7 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
module subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -479,8 +425,8 @@ module amg_c_onelev_mod
|
||||
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
|
||||
module subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -492,8 +438,7 @@ module amg_c_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
module subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -503,8 +448,8 @@ module amg_c_onelev_mod
|
||||
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
|
||||
module subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -515,6 +460,118 @@ module amg_c_onelev_mod
|
||||
end subroutine amg_c_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine c_base_onelev_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine c_base_onelev_allocate_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine c_base_onelev_free_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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
|
||||
end subroutine c_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine c_inner_do_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_wrk_free(wk,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine c_wrk_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine c_wrk_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine c_wrk_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine c_wrk_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
module function c_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_cmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
end function c_wrk_sizeof
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine c_remap_data_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine c_remap_move_alloc(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine c_remap_move_alloc
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
!
|
||||
! Function returning the size of the amg_prec_type data structure
|
||||
@@ -682,37 +739,6 @@ contains
|
||||
|
||||
end subroutine c_base_onelev_clone
|
||||
|
||||
subroutine c_base_onelev_move_alloc(lv, b,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine c_base_onelev_move_alloc
|
||||
|
||||
|
||||
function c_base_onelev_get_wrksize(lv) result(val)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
@@ -750,275 +776,5 @@ contains
|
||||
|
||||
end function c_base_onelev_get_wrksize
|
||||
|
||||
subroutine c_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
|
||||
subroutine c_base_onelev_free_wrk(lv,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine c_base_onelev_free_wrk
|
||||
|
||||
subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine inner_do_wrk_alloc
|
||||
end subroutine c_wrk_alloc
|
||||
|
||||
subroutine c_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine c_wrk_free
|
||||
|
||||
subroutine c_wrk_clone(wk,wkout,info)
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine c_wrk_clone
|
||||
|
||||
subroutine c_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine c_wrk_move_alloc
|
||||
|
||||
subroutine c_wrk_cnv(wk,info,vmold)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine c_wrk_cnv
|
||||
|
||||
function c_wrk_sizeof(wk) result(val)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_cmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
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
|
||||
|
||||
subroutine c_remap_move_alloc(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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine c_remap_move_alloc
|
||||
|
||||
end module amg_c_onelev_mod
|
||||
|
||||
@@ -646,6 +646,11 @@ contains
|
||||
if (allocated(prec%precv)) then
|
||||
do i=1,size(prec%precv)
|
||||
call prec%precv(i)%free(info)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end do
|
||||
deallocate(prec%precv,stat=info)
|
||||
end if
|
||||
|
||||
+134
-378
@@ -253,9 +253,7 @@ module amg_d_onelev_mod
|
||||
& d_base_onelev_free_wrk
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_ldspmat_type, psb_lpk_
|
||||
import :: amg_d_onelev_type
|
||||
module subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), intent(inout), target :: lv
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
@@ -267,10 +265,7 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
import :: psb_d_base_sparse_mat, psb_d_base_vect_type, &
|
||||
& psb_i_base_vect_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -282,10 +277,7 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
@@ -298,10 +290,8 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity, prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
@@ -315,10 +305,7 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_d_onelev_type, psb_d_base_vect_type, psb_dpk_, &
|
||||
& psb_d_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
|
||||
! Arguments
|
||||
module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
@@ -328,48 +315,32 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_free(lv,info)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_base_onelev_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_free_smoothers(lv,info)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_base_onelev_free_smoothers
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_check(lv,info)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_base_onelev_check
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
|
||||
import :: psb_dpk_, amg_d_onelev_type, amg_d_base_smoother_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_d_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -378,12 +349,8 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
|
||||
import :: psb_dpk_, amg_d_onelev_type, amg_d_base_solver_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_d_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -392,12 +359,8 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_setag(lv,val,info,pos)
|
||||
import :: psb_dpk_, amg_d_onelev_type, amg_d_base_aggregator_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_setag(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_d_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -406,13 +369,8 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
@@ -423,12 +381,8 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module 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
|
||||
character(len=*), intent(in) :: val
|
||||
@@ -439,12 +393,8 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
@@ -455,11 +405,8 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
module subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
& solver,tprol,global_num)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
implicit none
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
@@ -470,8 +417,7 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
module subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -480,8 +426,8 @@ module amg_d_onelev_mod
|
||||
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
|
||||
module subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -493,8 +439,7 @@ module amg_d_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
module subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -504,8 +449,8 @@ module amg_d_onelev_mod
|
||||
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
|
||||
module subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -516,6 +461,118 @@ module amg_d_onelev_mod
|
||||
end subroutine amg_d_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine d_base_onelev_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine d_base_onelev_allocate_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine d_base_onelev_free_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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
|
||||
end subroutine d_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine d_inner_do_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_wrk_free(wk,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine d_wrk_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine d_wrk_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine d_wrk_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine d_wrk_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
module function d_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_dmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
end function d_wrk_sizeof
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine d_remap_data_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine d_remap_move_alloc(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine d_remap_move_alloc
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
!
|
||||
! Function returning the size of the amg_prec_type data structure
|
||||
@@ -683,37 +740,6 @@ contains
|
||||
|
||||
end subroutine d_base_onelev_clone
|
||||
|
||||
subroutine d_base_onelev_move_alloc(lv, b,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine d_base_onelev_move_alloc
|
||||
|
||||
|
||||
function d_base_onelev_get_wrksize(lv) result(val)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
@@ -751,275 +777,5 @@ contains
|
||||
|
||||
end function d_base_onelev_get_wrksize
|
||||
|
||||
subroutine d_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
|
||||
subroutine d_base_onelev_free_wrk(lv,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine d_base_onelev_free_wrk
|
||||
|
||||
subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine inner_do_wrk_alloc
|
||||
end subroutine d_wrk_alloc
|
||||
|
||||
subroutine d_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine d_wrk_free
|
||||
|
||||
subroutine d_wrk_clone(wk,wkout,info)
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine d_wrk_clone
|
||||
|
||||
subroutine d_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine d_wrk_move_alloc
|
||||
|
||||
subroutine d_wrk_cnv(wk,info,vmold)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine d_wrk_cnv
|
||||
|
||||
function d_wrk_sizeof(wk) result(val)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_dmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
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
|
||||
|
||||
subroutine d_remap_move_alloc(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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine d_remap_move_alloc
|
||||
|
||||
end module amg_d_onelev_mod
|
||||
|
||||
@@ -646,6 +646,11 @@ contains
|
||||
if (allocated(prec%precv)) then
|
||||
do i=1,size(prec%precv)
|
||||
call prec%precv(i)%free(info)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end do
|
||||
deallocate(prec%precv,stat=info)
|
||||
end if
|
||||
|
||||
+134
-378
@@ -253,9 +253,7 @@ module amg_s_onelev_mod
|
||||
& s_base_onelev_free_wrk
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
import :: psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lsspmat_type, psb_lpk_
|
||||
import :: amg_s_onelev_type
|
||||
module subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), intent(inout), target :: lv
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
@@ -267,10 +265,7 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
import :: psb_s_base_sparse_mat, psb_s_base_vect_type, &
|
||||
& psb_i_base_vect_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -282,10 +277,7 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
@@ -298,10 +290,8 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity, prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
@@ -315,10 +305,7 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_s_onelev_type, psb_s_base_vect_type, psb_spk_, &
|
||||
& psb_s_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
|
||||
! Arguments
|
||||
module subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
@@ -328,48 +315,32 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_free(lv,info)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_base_onelev_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_free_smoothers(lv,info)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_base_onelev_free_smoothers
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_check(lv,info)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_base_onelev_check
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_setsm(lv,val,info,pos)
|
||||
import :: psb_spk_, amg_s_onelev_type, amg_s_base_smoother_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_setsm(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_s_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -378,12 +349,8 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_setsv(lv,val,info,pos)
|
||||
import :: psb_spk_, amg_s_onelev_type, amg_s_base_solver_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_setsv(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_s_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -392,12 +359,8 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_setag(lv,val,info,pos)
|
||||
import :: psb_spk_, amg_s_onelev_type, amg_s_base_aggregator_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_setag(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_s_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -406,13 +369,8 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
@@ -423,12 +381,8 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module 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
|
||||
character(len=*), intent(in) :: val
|
||||
@@ -439,12 +393,8 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
@@ -455,11 +405,8 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
module subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
& solver,tprol,global_num)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
implicit none
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
@@ -470,8 +417,7 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
module subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -480,8 +426,8 @@ module amg_s_onelev_mod
|
||||
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
|
||||
module subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -493,8 +439,7 @@ module amg_s_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
module subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -504,8 +449,8 @@ module amg_s_onelev_mod
|
||||
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
|
||||
module subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
@@ -516,6 +461,118 @@ module amg_s_onelev_mod
|
||||
end subroutine amg_s_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine s_base_onelev_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine s_base_onelev_allocate_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine s_base_onelev_free_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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
|
||||
end subroutine s_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine s_inner_do_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_wrk_free(wk,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine s_wrk_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine s_wrk_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine s_wrk_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine s_wrk_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
module function s_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_smlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
end function s_wrk_sizeof
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine s_remap_data_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine s_remap_move_alloc(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine s_remap_move_alloc
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
!
|
||||
! Function returning the size of the amg_prec_type data structure
|
||||
@@ -683,37 +740,6 @@ contains
|
||||
|
||||
end subroutine s_base_onelev_clone
|
||||
|
||||
subroutine s_base_onelev_move_alloc(lv, b,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine s_base_onelev_move_alloc
|
||||
|
||||
|
||||
function s_base_onelev_get_wrksize(lv) result(val)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
@@ -751,275 +777,5 @@ contains
|
||||
|
||||
end function s_base_onelev_get_wrksize
|
||||
|
||||
subroutine s_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
|
||||
subroutine s_base_onelev_free_wrk(lv,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine s_base_onelev_free_wrk
|
||||
|
||||
subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine inner_do_wrk_alloc
|
||||
end subroutine s_wrk_alloc
|
||||
|
||||
subroutine s_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine s_wrk_free
|
||||
|
||||
subroutine s_wrk_clone(wk,wkout,info)
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine s_wrk_clone
|
||||
|
||||
subroutine s_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine s_wrk_move_alloc
|
||||
|
||||
subroutine s_wrk_cnv(wk,info,vmold)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine s_wrk_cnv
|
||||
|
||||
function s_wrk_sizeof(wk) result(val)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_smlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
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
|
||||
|
||||
subroutine s_remap_move_alloc(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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine s_remap_move_alloc
|
||||
|
||||
end module amg_s_onelev_mod
|
||||
|
||||
@@ -646,6 +646,11 @@ contains
|
||||
if (allocated(prec%precv)) then
|
||||
do i=1,size(prec%precv)
|
||||
call prec%precv(i)%free(info)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end do
|
||||
deallocate(prec%precv,stat=info)
|
||||
end if
|
||||
|
||||
+134
-378
@@ -252,9 +252,7 @@ module amg_z_onelev_mod
|
||||
& z_base_onelev_free_wrk
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_lzspmat_type, psb_lpk_
|
||||
import :: amg_z_onelev_type
|
||||
module subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), intent(inout), target :: lv
|
||||
type(psb_zspmat_type), intent(in) :: a
|
||||
@@ -266,10 +264,7 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
import :: psb_z_base_sparse_mat, psb_z_base_vect_type, &
|
||||
& psb_i_base_vect_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -281,10 +276,7 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
@@ -297,10 +289,8 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity, prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
@@ -314,10 +304,7 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_z_onelev_type, psb_z_base_vect_type, psb_dpk_, &
|
||||
& psb_z_base_sparse_mat, psb_ipk_, psb_i_base_vect_type
|
||||
! Arguments
|
||||
module subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: amold
|
||||
@@ -327,48 +314,32 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_free(lv,info)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_z_base_onelev_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_free_smoothers(lv,info)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_z_base_onelev_free_smoothers
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_check(lv,info)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_z_base_onelev_check
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_setsm(lv,val,info,pos)
|
||||
import :: psb_dpk_, amg_z_onelev_type, amg_z_base_smoother_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_setsm(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_z_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -377,12 +348,8 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_setsv(lv,val,info,pos)
|
||||
import :: psb_dpk_, amg_z_onelev_type, amg_z_base_solver_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_setsv(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_z_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -391,12 +358,8 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_setag(lv,val,info,pos)
|
||||
import :: psb_dpk_, amg_z_onelev_type, amg_z_base_aggregator_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_setag(lv,val,info,pos)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_z_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -405,13 +368,8 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
@@ -422,12 +380,8 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module 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
|
||||
character(len=*), intent(in) :: val
|
||||
@@ -438,12 +392,8 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
module subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
Implicit None
|
||||
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
@@ -454,11 +404,8 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
module subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,&
|
||||
& solver,tprol,global_num)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
implicit none
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
@@ -469,8 +416,7 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
import
|
||||
module subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -479,8 +425,8 @@ module amg_z_onelev_mod
|
||||
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
|
||||
module subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -492,8 +438,7 @@ module amg_z_onelev_mod
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
import
|
||||
module subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -503,8 +448,8 @@ module amg_z_onelev_mod
|
||||
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
|
||||
module subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
@@ -515,6 +460,118 @@ module amg_z_onelev_mod
|
||||
end subroutine amg_z_base_onelev_map_prol_v
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine z_base_onelev_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine z_base_onelev_allocate_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine z_base_onelev_free_wrk
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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
|
||||
end subroutine z_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine z_inner_do_wrk_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_wrk_free(wk,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine z_wrk_free
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine z_wrk_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine z_wrk_move_alloc
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
end subroutine z_wrk_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
module function z_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_zmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
end function z_wrk_sizeof
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine z_remap_data_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
module subroutine z_remap_move_alloc(rmp, remap_out, info)
|
||||
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
|
||||
end subroutine z_remap_move_alloc
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
!
|
||||
! Function returning the size of the amg_prec_type data structure
|
||||
@@ -682,37 +739,6 @@ contains
|
||||
|
||||
end subroutine z_base_onelev_clone
|
||||
|
||||
subroutine z_base_onelev_move_alloc(lv, b,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine z_base_onelev_move_alloc
|
||||
|
||||
|
||||
function z_base_onelev_get_wrksize(lv) result(val)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
@@ -750,275 +776,5 @@ contains
|
||||
|
||||
end function z_base_onelev_get_wrksize
|
||||
|
||||
subroutine z_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
|
||||
subroutine z_base_onelev_free_wrk(lv,info)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine z_base_onelev_free_wrk
|
||||
|
||||
subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine inner_do_wrk_alloc
|
||||
end subroutine z_wrk_alloc
|
||||
|
||||
subroutine z_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine z_wrk_free
|
||||
|
||||
subroutine z_wrk_clone(wk,wkout,info)
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine z_wrk_clone
|
||||
|
||||
subroutine z_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine z_wrk_move_alloc
|
||||
|
||||
subroutine z_wrk_cnv(wk,info,vmold)
|
||||
use psb_base_mod
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine z_wrk_cnv
|
||||
|
||||
function z_wrk_sizeof(wk) result(val)
|
||||
use psb_realloc_mod
|
||||
implicit none
|
||||
class(amg_zmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
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
|
||||
|
||||
subroutine z_remap_move_alloc(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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine z_remap_move_alloc
|
||||
|
||||
end module amg_z_onelev_mod
|
||||
|
||||
@@ -646,6 +646,11 @@ contains
|
||||
if (allocated(prec%precv)) then
|
||||
do i=1,size(prec%precv)
|
||||
call prec%precv(i)%free(info)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end do
|
||||
deallocate(prec%precv,stat=info)
|
||||
end if
|
||||
|
||||
@@ -88,6 +88,7 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_descr'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
integer(psb_lpk_) :: gl_nrows,gl_ncols,gl_nzeros
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
@@ -122,6 +123,12 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (verbosity_ >=0) then
|
||||
gl_nrows = prec%precv(1)%base_a%get_nrows()
|
||||
gl_ncols = prec%precv(1)%base_a%get_ncols()
|
||||
gl_nzeros = prec%precv(1)%base_a%get_nzeros()
|
||||
call psb_sum(ctxt,gl_nrows)
|
||||
call psb_sum(ctxt,gl_ncols)
|
||||
call psb_sum(ctxt,gl_nzeros)
|
||||
!
|
||||
! The preconditioner description is printed by processor psb_root_.
|
||||
! This agrees with the fact that all the parameters defining the
|
||||
@@ -141,8 +148,11 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
|
||||
write(iout_,*)
|
||||
write(iout_,*) trim(prefix_),' Base matrix : ',&
|
||||
& gl_nrows, gl_ncols, gl_nzeros
|
||||
write(iout_,*)
|
||||
write(iout_,*) 'At level :',1,' we have ',np,' processes'
|
||||
|
||||
if (nlev == 1) then
|
||||
!
|
||||
! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.
|
||||
|
||||
@@ -88,6 +88,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_descr'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
integer(psb_lpk_) :: gl_nrows,gl_ncols,gl_nzeros
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
@@ -122,6 +123,12 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (verbosity_ >=0) then
|
||||
gl_nrows = prec%precv(1)%base_a%get_nrows()
|
||||
gl_ncols = prec%precv(1)%base_a%get_ncols()
|
||||
gl_nzeros = prec%precv(1)%base_a%get_nzeros()
|
||||
call psb_sum(ctxt,gl_nrows)
|
||||
call psb_sum(ctxt,gl_ncols)
|
||||
call psb_sum(ctxt,gl_nzeros)
|
||||
!
|
||||
! The preconditioner description is printed by processor psb_root_.
|
||||
! This agrees with the fact that all the parameters defining the
|
||||
@@ -141,8 +148,11 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
|
||||
write(iout_,*)
|
||||
write(iout_,*) trim(prefix_),' Base matrix : ',&
|
||||
& gl_nrows, gl_ncols, gl_nzeros
|
||||
write(iout_,*)
|
||||
write(iout_,*) 'At level :',1,' we have ',np,' processes'
|
||||
|
||||
if (nlev == 1) then
|
||||
!
|
||||
! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.
|
||||
|
||||
@@ -88,6 +88,7 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_descr'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
integer(psb_lpk_) :: gl_nrows,gl_ncols,gl_nzeros
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
@@ -122,6 +123,12 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (verbosity_ >=0) then
|
||||
gl_nrows = prec%precv(1)%base_a%get_nrows()
|
||||
gl_ncols = prec%precv(1)%base_a%get_ncols()
|
||||
gl_nzeros = prec%precv(1)%base_a%get_nzeros()
|
||||
call psb_sum(ctxt,gl_nrows)
|
||||
call psb_sum(ctxt,gl_ncols)
|
||||
call psb_sum(ctxt,gl_nzeros)
|
||||
!
|
||||
! The preconditioner description is printed by processor psb_root_.
|
||||
! This agrees with the fact that all the parameters defining the
|
||||
@@ -141,8 +148,11 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
|
||||
write(iout_,*)
|
||||
write(iout_,*) trim(prefix_),' Base matrix : ',&
|
||||
& gl_nrows, gl_ncols, gl_nzeros
|
||||
write(iout_,*)
|
||||
write(iout_,*) 'At level :',1,' we have ',np,' processes'
|
||||
|
||||
if (nlev == 1) then
|
||||
!
|
||||
! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.
|
||||
|
||||
@@ -88,6 +88,7 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_descr'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
integer(psb_lpk_) :: gl_nrows,gl_ncols,gl_nzeros
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
@@ -122,6 +123,12 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (verbosity_ >=0) then
|
||||
gl_nrows = prec%precv(1)%base_a%get_nrows()
|
||||
gl_ncols = prec%precv(1)%base_a%get_ncols()
|
||||
gl_nzeros = prec%precv(1)%base_a%get_nzeros()
|
||||
call psb_sum(ctxt,gl_nrows)
|
||||
call psb_sum(ctxt,gl_ncols)
|
||||
call psb_sum(ctxt,gl_nzeros)
|
||||
!
|
||||
! The preconditioner description is printed by processor psb_root_.
|
||||
! This agrees with the fact that all the parameters defining the
|
||||
@@ -141,8 +148,11 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
|
||||
write(iout_,*)
|
||||
write(iout_,*) trim(prefix_),' Base matrix : ',&
|
||||
& gl_nrows, gl_ncols, gl_nzeros
|
||||
write(iout_,*)
|
||||
write(iout_,*) 'At level :',1,' we have ',np,' processes'
|
||||
|
||||
if (nlev == 1) then
|
||||
!
|
||||
! Here we have a gigantic kludge just to handle Symmetrized Gauss-Seidel.
|
||||
|
||||
@@ -75,7 +75,12 @@ amg_z_base_onelev_setag.o \
|
||||
amg_z_base_onelev_setsm.o \
|
||||
amg_z_base_onelev_setsv.o \
|
||||
amg_z_base_onelev_map_rstr.o \
|
||||
amg_z_base_onelev_map_prol.o
|
||||
amg_z_base_onelev_map_prol.o \
|
||||
amg_s_base_onelev_wrk_handle.o \
|
||||
amg_d_base_onelev_wrk_handle.o \
|
||||
amg_c_base_onelev_wrk_handle.o \
|
||||
amg_z_base_onelev_wrk_handle.o
|
||||
|
||||
|
||||
|
||||
LIBNAME=libamg_prec.a
|
||||
@@ -89,4 +94,4 @@ veryclean: clean
|
||||
/bin/rm -f $(LIBNAME)
|
||||
|
||||
clean:
|
||||
/bin/rm -f $(OBJS) $(LOCAL_MODS)
|
||||
/bin/rm -f $(OBJS) $(LOCAL_MODS) *.smod
|
||||
|
||||
@@ -35,129 +35,132 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_build_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_build
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Unassociated base DESC')
|
||||
goto 9999
|
||||
end if
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; 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
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
& a_err='Unassociated base DESC')
|
||||
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 '
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
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
|
||||
end if
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_build
|
||||
end subroutine amg_c_base_onelev_build
|
||||
end submodule amg_c_base_onelev_build_impl
|
||||
|
||||
@@ -35,59 +35,60 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_check(lv,info)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_check_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_check
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_c_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_c_base_smoother_type), intent(in), target :: sm
|
||||
module subroutine amg_c_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_c_base_onelev_check
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_c_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_c_base_smoother_type), intent(in), target :: sm
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_c_base_onelev_check
|
||||
end submodule amg_c_base_onelev_check_impl
|
||||
|
||||
@@ -35,33 +35,36 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_cnv_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_cnv
|
||||
implicit none
|
||||
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_c_base_onelev_cnv
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
implicit none
|
||||
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_c_base_onelev_cnv
|
||||
end submodule amg_c_base_onelev_cnv_impl
|
||||
|
||||
@@ -35,277 +35,281 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_csetc_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetc
|
||||
use amg_c_base_aggregator_mod
|
||||
use amg_c_dec_aggregator_mod
|
||||
use amg_c_symdec_aggregator_mod
|
||||
use amg_c_jac_smoother
|
||||
use amg_c_as_smoother
|
||||
use amg_c_diag_solver
|
||||
use amg_c_l1_diag_solver
|
||||
use amg_c_jac_solver
|
||||
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
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_c_base_aggregator_mod
|
||||
use amg_c_dec_aggregator_mod
|
||||
use amg_c_symdec_aggregator_mod
|
||||
use amg_c_jac_smoother
|
||||
use amg_c_as_smoother
|
||||
use amg_c_diag_solver
|
||||
use amg_c_l1_diag_solver
|
||||
use amg_c_jac_solver
|
||||
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(AMG_HAVE_SLU)
|
||||
use amg_c_slu_solver
|
||||
use amg_c_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_c_mumps_solver
|
||||
use amg_c_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_csetc'
|
||||
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
|
||||
type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold
|
||||
type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold
|
||||
type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold
|
||||
type(amg_c_jac_solver_type) :: amg_c_jac_solver_mold
|
||||
type(amg_c_l1_jac_solver_type) :: amg_c_l1_jac_solver_mold
|
||||
type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold
|
||||
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
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_csetc'
|
||||
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
|
||||
type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold
|
||||
type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold
|
||||
type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold
|
||||
type(amg_c_jac_solver_type) :: amg_c_jac_solver_mold
|
||||
type(amg_c_l1_jac_solver_type) :: amg_c_l1_jac_solver_mold
|
||||
type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold
|
||||
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(AMG_HAVE_SLU)
|
||||
type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold
|
||||
type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold
|
||||
type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
ival = lv%stringval(val)
|
||||
ival = lv%stringval(val)
|
||||
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(amg_c_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_c_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_c_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
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('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 ('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)
|
||||
|
||||
case ('DIAG','JACOBI')
|
||||
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
|
||||
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 ('L1-DIAG','L1-JACOBI')
|
||||
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 ('GS','FGS','FWGS')
|
||||
call lv%set(amg_c_gs_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)
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
|
||||
case ('AS')
|
||||
call lv%set(amg_c_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_ilu_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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_c_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_c_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_c_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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','JACOBI')
|
||||
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI')
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case ('SLU')
|
||||
call lv%set(amg_c_slu_solver_mold,info,pos=pos)
|
||||
case ('SLU')
|
||||
call lv%set(amg_c_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_csetc
|
||||
end subroutine amg_c_base_onelev_csetc
|
||||
end submodule amg_c_base_onelev_csetc_impl
|
||||
|
||||
@@ -35,234 +35,238 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_cseti_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_cseti
|
||||
use amg_c_base_aggregator_mod
|
||||
use amg_c_dec_aggregator_mod
|
||||
use amg_c_symdec_aggregator_mod
|
||||
use amg_c_jac_smoother
|
||||
use amg_c_as_smoother
|
||||
use amg_c_diag_solver
|
||||
use amg_c_l1_diag_solver
|
||||
use amg_c_ilu_solver
|
||||
use amg_c_id_solver
|
||||
use amg_c_gs_solver
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_c_base_aggregator_mod
|
||||
use amg_c_dec_aggregator_mod
|
||||
use amg_c_symdec_aggregator_mod
|
||||
use amg_c_jac_smoother
|
||||
use amg_c_as_smoother
|
||||
use amg_c_diag_solver
|
||||
use amg_c_l1_diag_solver
|
||||
use amg_c_ilu_solver
|
||||
use amg_c_id_solver
|
||||
use amg_c_gs_solver
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
use amg_c_slu_solver
|
||||
use amg_c_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_c_mumps_solver
|
||||
use amg_c_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_cseti'
|
||||
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
|
||||
type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold
|
||||
type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold
|
||||
type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold
|
||||
type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold
|
||||
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
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_cseti'
|
||||
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
|
||||
type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold
|
||||
type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold
|
||||
type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold
|
||||
type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold
|
||||
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
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold
|
||||
type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold
|
||||
type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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 (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_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 (amg_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)
|
||||
|
||||
case (amg_as_)
|
||||
call lv%set(amg_c_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_c_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_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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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('SUB_SOLVE')
|
||||
select case (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_c_id_solver_mold,info,pos=pos)
|
||||
case (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_l1_diag_scale_)
|
||||
call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
|
||||
case (amg_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 (amg_gs_)
|
||||
call lv%set(amg_c_gs_solver_mold,info,pos=pos)
|
||||
case (amg_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)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
|
||||
case (amg_as_)
|
||||
call lv%set(amg_c_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_c_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_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 :)
|
||||
!
|
||||
end select
|
||||
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 (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_c_id_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_l1_diag_scale_)
|
||||
call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_gs_)
|
||||
call lv%set(amg_c_gs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_c_slu_solver_mold,info,pos=pos)
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_c_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_c_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_cseti
|
||||
end subroutine amg_c_base_onelev_cseti
|
||||
end submodule amg_c_base_onelev_cseti_impl
|
||||
|
||||
@@ -35,71 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_csetr_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetr
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_csetr'
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
select case (psb_toupper(what))
|
||||
select case (psb_toupper(what))
|
||||
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
|
||||
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
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
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
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_csetr
|
||||
end subroutine amg_c_base_onelev_csetr
|
||||
end submodule amg_c_base_onelev_csetr_impl
|
||||
|
||||
@@ -42,114 +42,116 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_descr_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_descr
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_c_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_c_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_descr
|
||||
end subroutine amg_c_base_onelev_descr
|
||||
end submodule amg_c_base_onelev_descr_impl
|
||||
|
||||
@@ -35,135 +35,137 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_dump_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_dump
|
||||
implicit none
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_c"
|
||||
end if
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_c"
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_dump
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_dump
|
||||
end submodule amg_c_base_onelev_dump_impl
|
||||
|
||||
@@ -35,41 +35,43 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_free(lv,info)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_free_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_free
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
|
||||
call lv%nullify()
|
||||
call lv%nullify()
|
||||
|
||||
end subroutine amg_c_base_onelev_free
|
||||
end subroutine amg_c_base_onelev_free
|
||||
end submodule amg_c_base_onelev_free_impl
|
||||
|
||||
@@ -35,26 +35,28 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_free_smoothers(lv,info)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_dree_smoothers_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_free_smoothers
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_c_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
end subroutine amg_c_base_onelev_free_smoothers
|
||||
end subroutine amg_c_base_onelev_free_smoothers
|
||||
end submodule amg_c_base_onelev_dree_smoothers_impl
|
||||
|
||||
@@ -35,112 +35,113 @@
|
||||
! 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
|
||||
|
||||
type(psb_c_vect_type), pointer :: vtx_
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_map_prol_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
type(psb_c_vect_type), pointer :: vtx_
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: me, np, rme, rnp
|
||||
complex(psb_spk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_c_vect_type) :: tv
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
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)
|
||||
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()
|
||||
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)
|
||||
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)
|
||||
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,mold=vect_u%v)
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v)
|
||||
!!$ 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 psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx_,vty=vty)
|
||||
end associate
|
||||
call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
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
|
||||
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
|
||||
|
||||
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(:)
|
||||
end subroutine amg_c_base_onelev_map_prol_v
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
module subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
complex(psb_spk_), intent(inout) :: u(:)
|
||||
complex(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_c_base_onelev_map_prol_impl
|
||||
|
||||
@@ -36,114 +36,115 @@
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_map_rstr_impl
|
||||
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
|
||||
type(psb_c_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_c_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
type(psb_c_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
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, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context map rstr',rme,rnp,me,np
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
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,mold=vect_u%v)
|
||||
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,mold=vect_u%v)
|
||||
!!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
|
||||
!!$ & psb_errstatus_fatal()
|
||||
!!$ flush(0)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
!!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
|
||||
call psb_snd(ctxt,tv%v%v(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
call psb_snd(ctxt,tv%v%v(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)
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()
|
||||
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
|
||||
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 ',psb_errstatus_fatal()
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) me,' map_rstr calling U2V: ',me,np
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
!!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()
|
||||
end subroutine amg_c_base_onelev_map_rstr_v
|
||||
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(:)
|
||||
module subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_spk_), intent(in) :: alpha, beta
|
||||
complex(psb_spk_), intent(inout) :: u(:)
|
||||
complex(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_c_base_onelev_map_rstr_impl
|
||||
|
||||
@@ -83,109 +83,111 @@
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_mat_asb_impl
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_mat_asb
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout), target :: lv
|
||||
type(psb_cspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_lcspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_cspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
implicit none
|
||||
|
||||
name='amg_c_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(inout), target :: lv
|
||||
type(psb_cspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_lcspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_cspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
name='amg_c_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_mat_asb
|
||||
end subroutine amg_c_base_onelev_mat_asb
|
||||
end submodule amg_c_base_onelev_mat_asb_impl
|
||||
|
||||
@@ -42,109 +42,112 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_memory_use_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_memory_use
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_c_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity,prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_c_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
endif
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
end if
|
||||
endif
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_memory_use
|
||||
end subroutine amg_c_base_onelev_memory_use
|
||||
end submodule amg_c_base_onelev_memory_use_impl
|
||||
|
||||
@@ -35,48 +35,50 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_setag_impl
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_setag
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_c_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
info = psb_success_
|
||||
implicit none
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_c_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_setag
|
||||
|
||||
end subroutine amg_c_base_onelev_setag
|
||||
|
||||
end submodule amg_c_base_onelev_setag_impl
|
||||
|
||||
@@ -35,72 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_setsm(lev,val,info,pos)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_setsm_impl
|
||||
use psb_base_mod
|
||||
use amg_c_prec_mod, amg_protect_name => amg_c_base_onelev_setsm
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_c_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_setsm(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_c_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lev%sm2a)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
lev%sm2 => null()
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lev%sm)) then
|
||||
if (.not.same_type_as(lev%sm,val)) then
|
||||
call lev%sm%free(info)
|
||||
deallocate(lev%sm, stat=info)
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
lv%sm2 => null()
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lev%sm)) then
|
||||
allocate(lev%sm,mold=val)
|
||||
end if
|
||||
call lev%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (.not.same_type_as(lev%sm2a,val)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a)) then
|
||||
allocate(lev%sm2a,mold=val)
|
||||
end if
|
||||
call lev%sm2a%default()
|
||||
lev%sm2 => lev%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_c_base_onelev_setsm
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lv%sm)) then
|
||||
if (.not.same_type_as(lv%sm,val)) then
|
||||
call lv%sm%free(info)
|
||||
deallocate(lv%sm, stat=info)
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lv%sm)) then
|
||||
allocate(lv%sm,mold=val)
|
||||
end if
|
||||
call lv%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (.not.same_type_as(lv%sm2a,val)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a)) then
|
||||
allocate(lv%sm2a,mold=val)
|
||||
end if
|
||||
call lv%sm2a%default()
|
||||
lv%sm2 => lv%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_c_base_onelev_setsm
|
||||
|
||||
end submodule amg_c_base_onelev_setsm_impl
|
||||
|
||||
@@ -35,110 +35,111 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_c_base_onelev_setsv(lev,val,info,pos)
|
||||
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_setsv_impl
|
||||
use psb_base_mod
|
||||
use amg_c_prec_mod, amg_protect_name => amg_c_base_onelev_setsv
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_c_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
contains
|
||||
module subroutine amg_c_base_onelev_setsv(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
info = psb_success_
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_c_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lev%sm)) then
|
||||
if (allocated(lev%sm%sv)) then
|
||||
if (.not.same_type_as(lev%sm%sv,val)) then
|
||||
call lev%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm%sv,stat=info)
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if (allocated(lv%sm%sv)) then
|
||||
if (.not.same_type_as(lv%sm%sv,val)) then
|
||||
call lv%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
allocate(lv%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lv%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
if (.not.allocated(lev%sm%sv)) then
|
||||
allocate(lev%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
end if
|
||||
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then
|
||||
|
||||
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (allocated(lev%sm2a%sv)) then
|
||||
if (.not.same_type_as(lev%sm2a%sv,val)) then
|
||||
call lev%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm2a%sv,stat=info)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (allocated(lv%sm2a%sv)) then
|
||||
if (.not.same_type_as(lv%sm2a%sv,val)) then
|
||||
call lv%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm2a%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a%sv)) then
|
||||
allocate(lv%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a%sv)) then
|
||||
allocate(lev%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_setsv
|
||||
call lv%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_c_base_onelev_setsv
|
||||
|
||||
end submodule amg_c_base_onelev_setsv_impl
|
||||
|
||||
@@ -0,0 +1,333 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific prior written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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.
|
||||
!
|
||||
!
|
||||
submodule (amg_c_onelev_mod) amg_c_base_onelev_wrk_handle_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
|
||||
module subroutine c_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine c_base_onelev_move_alloc
|
||||
|
||||
module subroutine c_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
module subroutine c_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_c_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine c_base_onelev_free_wrk
|
||||
|
||||
module subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call c_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call c_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call c_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call c_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
end subroutine c_wrk_alloc
|
||||
|
||||
module subroutine c_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine c_inner_do_wrk_alloc
|
||||
|
||||
|
||||
module subroutine c_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine c_wrk_free
|
||||
|
||||
module subroutine c_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine c_wrk_clone
|
||||
|
||||
module subroutine c_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine c_wrk_move_alloc
|
||||
|
||||
module subroutine c_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_cmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine c_wrk_cnv
|
||||
|
||||
module function c_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_cmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
end if
|
||||
end function c_wrk_sizeof
|
||||
|
||||
module subroutine c_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
|
||||
module subroutine c_remap_move_alloc(rmp, remap_out, info)
|
||||
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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine c_remap_move_alloc
|
||||
|
||||
end submodule amg_c_base_onelev_wrk_handle_impl
|
||||
@@ -35,129 +35,132 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_build_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_build
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Unassociated base DESC')
|
||||
goto 9999
|
||||
end if
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; 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
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
& a_err='Unassociated base DESC')
|
||||
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 '
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
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
|
||||
end if
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_d_base_onelev_build
|
||||
end subroutine amg_d_base_onelev_build
|
||||
end submodule amg_d_base_onelev_build_impl
|
||||
|
||||
@@ -35,59 +35,60 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_check(lv,info)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_check_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_check
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_d_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_d_base_smoother_type), intent(in), target :: sm
|
||||
module subroutine amg_d_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_d_base_onelev_check
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_d_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_d_base_smoother_type), intent(in), target :: sm
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_d_base_onelev_check
|
||||
end submodule amg_d_base_onelev_check_impl
|
||||
|
||||
@@ -35,33 +35,36 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_cnv_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_cnv
|
||||
implicit none
|
||||
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_d_base_onelev_cnv
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
implicit none
|
||||
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_d_base_onelev_cnv
|
||||
end submodule amg_d_base_onelev_cnv_impl
|
||||
|
||||
@@ -35,305 +35,309 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_csetc_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetc
|
||||
use amg_d_base_aggregator_mod
|
||||
use amg_d_dec_aggregator_mod
|
||||
use amg_d_symdec_aggregator_mod
|
||||
use amg_d_parmatch_aggregator_mod
|
||||
use amg_d_poly_smoother
|
||||
use amg_d_jac_smoother
|
||||
use amg_d_as_smoother
|
||||
use amg_d_diag_solver
|
||||
use amg_d_l1_diag_solver
|
||||
use amg_d_jac_solver
|
||||
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
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_d_base_aggregator_mod
|
||||
use amg_d_dec_aggregator_mod
|
||||
use amg_d_symdec_aggregator_mod
|
||||
use amg_d_parmatch_aggregator_mod
|
||||
use amg_d_poly_smoother
|
||||
use amg_d_jac_smoother
|
||||
use amg_d_as_smoother
|
||||
use amg_d_diag_solver
|
||||
use amg_d_l1_diag_solver
|
||||
use amg_d_jac_solver
|
||||
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(AMG_HAVE_UMF)
|
||||
use amg_d_umf_solver
|
||||
use amg_d_umf_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
use amg_d_sludist_solver
|
||||
use amg_d_sludist_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
use amg_d_slu_solver
|
||||
use amg_d_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_d_mumps_solver
|
||||
use amg_d_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_csetc'
|
||||
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
|
||||
type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold
|
||||
type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold
|
||||
type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold
|
||||
type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold
|
||||
type(amg_d_l1_jac_solver_type) :: amg_d_l1_jac_solver_mold
|
||||
type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold
|
||||
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
|
||||
type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_csetc'
|
||||
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
|
||||
type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold
|
||||
type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold
|
||||
type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold
|
||||
type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold
|
||||
type(amg_d_l1_jac_solver_type) :: amg_d_l1_jac_solver_mold
|
||||
type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold
|
||||
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
|
||||
type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold
|
||||
#if defined(AMG_HAVE_UMF)
|
||||
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
|
||||
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold
|
||||
type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold
|
||||
type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold
|
||||
type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
ival = lv%stringval(val)
|
||||
ival = lv%stringval(val)
|
||||
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(amg_d_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('POLY')
|
||||
call lv%set(amg_d_poly_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_d_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_d_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
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('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 ('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)
|
||||
|
||||
case ('DIAG','JACOBI')
|
||||
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
|
||||
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 ('L1-DIAG','L1-JACOBI')
|
||||
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 ('GS','FGS','FWGS')
|
||||
call lv%set(amg_d_gs_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)
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
|
||||
case ('AS')
|
||||
call lv%set(amg_d_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_ilu_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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case ('POLY')
|
||||
call lv%set(amg_d_poly_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_d_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_d_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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','JACOBI')
|
||||
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI')
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case ('SLU')
|
||||
call lv%set(amg_d_slu_solver_mold,info,pos=pos)
|
||||
case ('SLU')
|
||||
call lv%set(amg_d_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_SLUDIST
|
||||
case ('SLUDIST')
|
||||
call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
|
||||
case ('SLUDIST')
|
||||
call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_UMF
|
||||
case ('UMF')
|
||||
call lv%set(amg_d_umf_solver_mold,info,pos=pos)
|
||||
case ('UMF')
|
||||
call lv%set(amg_d_umf_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('COUP','COUPLED')
|
||||
allocate(amg_d_parmatch_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('COUP','COUPLED')
|
||||
allocate(amg_d_parmatch_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_d_base_onelev_csetc
|
||||
end subroutine amg_d_base_onelev_csetc
|
||||
end submodule amg_d_base_onelev_csetc_impl
|
||||
|
||||
@@ -35,255 +35,259 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_cseti_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_cseti
|
||||
use amg_d_base_aggregator_mod
|
||||
use amg_d_dec_aggregator_mod
|
||||
use amg_d_symdec_aggregator_mod
|
||||
use amg_d_parmatch_aggregator_mod
|
||||
use amg_d_jac_smoother
|
||||
use amg_d_as_smoother
|
||||
use amg_d_diag_solver
|
||||
use amg_d_l1_diag_solver
|
||||
use amg_d_ilu_solver
|
||||
use amg_d_id_solver
|
||||
use amg_d_gs_solver
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_d_base_aggregator_mod
|
||||
use amg_d_dec_aggregator_mod
|
||||
use amg_d_symdec_aggregator_mod
|
||||
use amg_d_parmatch_aggregator_mod
|
||||
use amg_d_jac_smoother
|
||||
use amg_d_as_smoother
|
||||
use amg_d_diag_solver
|
||||
use amg_d_l1_diag_solver
|
||||
use amg_d_ilu_solver
|
||||
use amg_d_id_solver
|
||||
use amg_d_gs_solver
|
||||
#if defined(AMG_HAVE_UMF)
|
||||
use amg_d_umf_solver
|
||||
use amg_d_umf_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
use amg_d_sludist_solver
|
||||
use amg_d_sludist_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
use amg_d_slu_solver
|
||||
use amg_d_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_d_mumps_solver
|
||||
use amg_d_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_cseti'
|
||||
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
|
||||
type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold
|
||||
type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold
|
||||
type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold
|
||||
type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold
|
||||
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
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_cseti'
|
||||
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
|
||||
type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold
|
||||
type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold
|
||||
type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold
|
||||
type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold
|
||||
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
|
||||
#if defined(AMG_HAVE_UMF)
|
||||
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
|
||||
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold
|
||||
type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold
|
||||
type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold
|
||||
type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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 (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_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 (amg_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)
|
||||
|
||||
case (amg_as_)
|
||||
call lv%set(amg_d_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_d_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_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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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('SUB_SOLVE')
|
||||
select case (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_d_id_solver_mold,info,pos=pos)
|
||||
case (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_l1_diag_scale_)
|
||||
call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
case (amg_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 (amg_gs_)
|
||||
call lv%set(amg_d_gs_solver_mold,info,pos=pos)
|
||||
case (amg_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)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
|
||||
case (amg_as_)
|
||||
call lv%set(amg_d_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_d_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_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 :)
|
||||
!
|
||||
end select
|
||||
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 (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_d_id_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_l1_diag_scale_)
|
||||
call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_gs_)
|
||||
call lv%set(amg_d_gs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_d_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_d_slu_solver_mold,info,pos=pos)
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_d_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_d_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_SLUDIST
|
||||
case (amg_sludist_)
|
||||
call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
|
||||
case (amg_sludist_)
|
||||
call lv%set(amg_d_sludist_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_UMF
|
||||
case (amg_umf_)
|
||||
call lv%set(amg_d_umf_solver_mold,info,pos=pos)
|
||||
case (amg_umf_)
|
||||
call lv%set(amg_d_umf_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_d_base_onelev_cseti
|
||||
end subroutine amg_d_base_onelev_cseti
|
||||
end submodule amg_d_base_onelev_cseti_impl
|
||||
|
||||
@@ -35,71 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_csetr_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetr
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_csetr'
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
select case (psb_toupper(what))
|
||||
select case (psb_toupper(what))
|
||||
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
|
||||
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
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
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
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_d_base_onelev_csetr
|
||||
end subroutine amg_d_base_onelev_csetr
|
||||
end submodule amg_d_base_onelev_csetr_impl
|
||||
|
||||
@@ -42,114 +42,116 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_descr_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_descr
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_d_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_d_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_d_base_onelev_descr
|
||||
end subroutine amg_d_base_onelev_descr
|
||||
end submodule amg_d_base_onelev_descr_impl
|
||||
|
||||
@@ -35,135 +35,137 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_dump_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_dump
|
||||
implicit none
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_d"
|
||||
end if
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_d"
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_dump
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_dump
|
||||
end submodule amg_d_base_onelev_dump_impl
|
||||
|
||||
@@ -35,41 +35,43 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_free(lv,info)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_free_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_free
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
|
||||
call lv%nullify()
|
||||
call lv%nullify()
|
||||
|
||||
end subroutine amg_d_base_onelev_free
|
||||
end subroutine amg_d_base_onelev_free
|
||||
end submodule amg_d_base_onelev_free_impl
|
||||
|
||||
@@ -35,26 +35,28 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_free_smoothers(lv,info)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_dree_smoothers_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_free_smoothers
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_d_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
end subroutine amg_d_base_onelev_free_smoothers
|
||||
end subroutine amg_d_base_onelev_free_smoothers
|
||||
end submodule amg_d_base_onelev_dree_smoothers_impl
|
||||
|
||||
@@ -35,112 +35,113 @@
|
||||
! 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
|
||||
|
||||
type(psb_d_vect_type), pointer :: vtx_
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_map_prol_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_d_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
type(psb_d_vect_type), pointer :: vtx_
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: me, np, rme, rnp
|
||||
real(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_d_vect_type) :: tv
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
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)
|
||||
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()
|
||||
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)
|
||||
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)
|
||||
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,mold=vect_u%v)
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v)
|
||||
!!$ 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 psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx_,vty=vty)
|
||||
end associate
|
||||
call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
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
|
||||
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
|
||||
|
||||
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(:)
|
||||
end subroutine amg_d_base_onelev_map_prol_v
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
module subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
real(psb_dpk_), intent(inout) :: u(:)
|
||||
real(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_d_base_onelev_map_prol_impl
|
||||
|
||||
@@ -36,114 +36,115 @@
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_map_rstr_impl
|
||||
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
|
||||
type(psb_d_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
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
|
||||
type(psb_d_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
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, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context map rstr',rme,rnp,me,np
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
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,mold=vect_u%v)
|
||||
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,mold=vect_u%v)
|
||||
!!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
|
||||
!!$ & psb_errstatus_fatal()
|
||||
!!$ flush(0)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
!!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
|
||||
call psb_snd(ctxt,tv%v%v(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
call psb_snd(ctxt,tv%v%v(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)
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()
|
||||
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
|
||||
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 ',psb_errstatus_fatal()
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) me,' map_rstr calling U2V: ',me,np
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
!!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()
|
||||
end subroutine amg_d_base_onelev_map_rstr_v
|
||||
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(:)
|
||||
module subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_dpk_), intent(in) :: alpha, beta
|
||||
real(psb_dpk_), intent(inout) :: u(:)
|
||||
real(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_d_base_onelev_map_rstr_impl
|
||||
|
||||
@@ -83,109 +83,111 @@
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_mat_asb_impl
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_mat_asb
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout), target :: lv
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_dspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
implicit none
|
||||
|
||||
name='amg_d_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega)
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(inout), target :: lv
|
||||
type(psb_dspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_ldspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_dspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
name='amg_d_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega)
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_d_base_onelev_mat_asb
|
||||
end subroutine amg_d_base_onelev_mat_asb
|
||||
end submodule amg_d_base_onelev_mat_asb_impl
|
||||
|
||||
@@ -42,109 +42,112 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_memory_use_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_memory_use
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_d_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity,prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_d_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
endif
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
end if
|
||||
endif
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_d_base_onelev_memory_use
|
||||
end subroutine amg_d_base_onelev_memory_use
|
||||
end submodule amg_d_base_onelev_memory_use_impl
|
||||
|
||||
@@ -35,48 +35,50 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_setag_impl
|
||||
use psb_base_mod
|
||||
use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_setag
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_d_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
info = psb_success_
|
||||
implicit none
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_d_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_setag
|
||||
|
||||
end subroutine amg_d_base_onelev_setag
|
||||
|
||||
end submodule amg_d_base_onelev_setag_impl
|
||||
|
||||
@@ -35,72 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_setsm(lev,val,info,pos)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_setsm_impl
|
||||
use psb_base_mod
|
||||
use amg_d_prec_mod, amg_protect_name => amg_d_base_onelev_setsm
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_d_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_setsm(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_d_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lev%sm2a)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
lev%sm2 => null()
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lev%sm)) then
|
||||
if (.not.same_type_as(lev%sm,val)) then
|
||||
call lev%sm%free(info)
|
||||
deallocate(lev%sm, stat=info)
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
lv%sm2 => null()
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lev%sm)) then
|
||||
allocate(lev%sm,mold=val)
|
||||
end if
|
||||
call lev%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (.not.same_type_as(lev%sm2a,val)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a)) then
|
||||
allocate(lev%sm2a,mold=val)
|
||||
end if
|
||||
call lev%sm2a%default()
|
||||
lev%sm2 => lev%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_d_base_onelev_setsm
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lv%sm)) then
|
||||
if (.not.same_type_as(lv%sm,val)) then
|
||||
call lv%sm%free(info)
|
||||
deallocate(lv%sm, stat=info)
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lv%sm)) then
|
||||
allocate(lv%sm,mold=val)
|
||||
end if
|
||||
call lv%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (.not.same_type_as(lv%sm2a,val)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a)) then
|
||||
allocate(lv%sm2a,mold=val)
|
||||
end if
|
||||
call lv%sm2a%default()
|
||||
lv%sm2 => lv%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_d_base_onelev_setsm
|
||||
|
||||
end submodule amg_d_base_onelev_setsm_impl
|
||||
|
||||
@@ -35,110 +35,111 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_d_base_onelev_setsv(lev,val,info,pos)
|
||||
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_setsv_impl
|
||||
use psb_base_mod
|
||||
use amg_d_prec_mod, amg_protect_name => amg_d_base_onelev_setsv
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_d_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
contains
|
||||
module subroutine amg_d_base_onelev_setsv(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
info = psb_success_
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_d_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lev%sm)) then
|
||||
if (allocated(lev%sm%sv)) then
|
||||
if (.not.same_type_as(lev%sm%sv,val)) then
|
||||
call lev%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm%sv,stat=info)
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if (allocated(lv%sm%sv)) then
|
||||
if (.not.same_type_as(lv%sm%sv,val)) then
|
||||
call lv%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
allocate(lv%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lv%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
if (.not.allocated(lev%sm%sv)) then
|
||||
allocate(lev%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
end if
|
||||
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then
|
||||
|
||||
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (allocated(lev%sm2a%sv)) then
|
||||
if (.not.same_type_as(lev%sm2a%sv,val)) then
|
||||
call lev%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm2a%sv,stat=info)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (allocated(lv%sm2a%sv)) then
|
||||
if (.not.same_type_as(lv%sm2a%sv,val)) then
|
||||
call lv%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm2a%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a%sv)) then
|
||||
allocate(lv%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a%sv)) then
|
||||
allocate(lev%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_setsv
|
||||
call lv%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_d_base_onelev_setsv
|
||||
|
||||
end submodule amg_d_base_onelev_setsv_impl
|
||||
|
||||
@@ -0,0 +1,333 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific prior written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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.
|
||||
!
|
||||
!
|
||||
submodule (amg_d_onelev_mod) amg_d_base_onelev_wrk_handle_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
|
||||
module subroutine d_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine d_base_onelev_move_alloc
|
||||
|
||||
module subroutine d_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
module subroutine d_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_d_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine d_base_onelev_free_wrk
|
||||
|
||||
module subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call d_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call d_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call d_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call d_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
end subroutine d_wrk_alloc
|
||||
|
||||
module subroutine d_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine d_inner_do_wrk_alloc
|
||||
|
||||
|
||||
module subroutine d_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine d_wrk_free
|
||||
|
||||
module subroutine d_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine d_wrk_clone
|
||||
|
||||
module subroutine d_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine d_wrk_move_alloc
|
||||
|
||||
module subroutine d_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_dmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine d_wrk_cnv
|
||||
|
||||
module function d_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_dmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
end if
|
||||
end function d_wrk_sizeof
|
||||
|
||||
module subroutine d_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
|
||||
module subroutine d_remap_move_alloc(rmp, remap_out, info)
|
||||
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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine d_remap_move_alloc
|
||||
|
||||
end submodule amg_d_base_onelev_wrk_handle_impl
|
||||
@@ -35,129 +35,132 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_build_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_build
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Unassociated base DESC')
|
||||
goto 9999
|
||||
end if
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; 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
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
& a_err='Unassociated base DESC')
|
||||
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 '
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
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
|
||||
end if
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_s_base_onelev_build
|
||||
end subroutine amg_s_base_onelev_build
|
||||
end submodule amg_s_base_onelev_build_impl
|
||||
|
||||
@@ -35,59 +35,60 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_check(lv,info)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_check_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_check
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_s_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_s_base_smoother_type), intent(in), target :: sm
|
||||
module subroutine amg_s_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_s_base_onelev_check
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_s_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_s_base_smoother_type), intent(in), target :: sm
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_s_base_onelev_check
|
||||
end submodule amg_s_base_onelev_check_impl
|
||||
|
||||
@@ -35,33 +35,36 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_cnv_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_cnv
|
||||
implicit none
|
||||
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_s_base_onelev_cnv
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
implicit none
|
||||
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_s_base_onelev_cnv
|
||||
end submodule amg_s_base_onelev_cnv_impl
|
||||
|
||||
@@ -35,285 +35,289 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_csetc_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_csetc
|
||||
use amg_s_base_aggregator_mod
|
||||
use amg_s_dec_aggregator_mod
|
||||
use amg_s_symdec_aggregator_mod
|
||||
use amg_s_parmatch_aggregator_mod
|
||||
use amg_s_poly_smoother
|
||||
use amg_s_jac_smoother
|
||||
use amg_s_as_smoother
|
||||
use amg_s_diag_solver
|
||||
use amg_s_l1_diag_solver
|
||||
use amg_s_jac_solver
|
||||
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
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_base_aggregator_mod
|
||||
use amg_s_dec_aggregator_mod
|
||||
use amg_s_symdec_aggregator_mod
|
||||
use amg_s_parmatch_aggregator_mod
|
||||
use amg_s_poly_smoother
|
||||
use amg_s_jac_smoother
|
||||
use amg_s_as_smoother
|
||||
use amg_s_diag_solver
|
||||
use amg_s_l1_diag_solver
|
||||
use amg_s_jac_solver
|
||||
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(AMG_HAVE_SLU)
|
||||
use amg_s_slu_solver
|
||||
use amg_s_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_s_mumps_solver
|
||||
use amg_s_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_csetc'
|
||||
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
|
||||
type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold
|
||||
type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold
|
||||
type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold
|
||||
type(amg_s_jac_solver_type) :: amg_s_jac_solver_mold
|
||||
type(amg_s_l1_jac_solver_type) :: amg_s_l1_jac_solver_mold
|
||||
type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold
|
||||
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
|
||||
type(amg_s_poly_smoother_type) :: amg_s_poly_smoother_mold
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_csetc'
|
||||
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
|
||||
type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold
|
||||
type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold
|
||||
type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold
|
||||
type(amg_s_jac_solver_type) :: amg_s_jac_solver_mold
|
||||
type(amg_s_l1_jac_solver_type) :: amg_s_l1_jac_solver_mold
|
||||
type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold
|
||||
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
|
||||
type(amg_s_poly_smoother_type) :: amg_s_poly_smoother_mold
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold
|
||||
type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold
|
||||
type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
ival = lv%stringval(val)
|
||||
ival = lv%stringval(val)
|
||||
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(amg_s_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('POLY')
|
||||
call lv%set(amg_s_poly_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_s_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_s_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_s_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
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('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 ('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)
|
||||
|
||||
case ('DIAG','JACOBI')
|
||||
call lv%set(amg_s_diag_solver_mold,info,pos=pos)
|
||||
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 ('L1-DIAG','L1-JACOBI')
|
||||
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 ('GS','FGS','FWGS')
|
||||
call lv%set(amg_s_gs_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)
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_s_bwgs_solver_mold,info,pos=pos)
|
||||
case ('AS')
|
||||
call lv%set(amg_s_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_ilu_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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case ('POLY')
|
||||
call lv%set(amg_s_poly_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_s_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_s_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_s_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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','JACOBI')
|
||||
call lv%set(amg_s_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI')
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case ('SLU')
|
||||
call lv%set(amg_s_slu_solver_mold,info,pos=pos)
|
||||
case ('SLU')
|
||||
call lv%set(amg_s_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_s_mumps_solver_mold,info,pos=pos)
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_s_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('COUP','COUPLED')
|
||||
allocate(amg_s_parmatch_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('COUP','COUPLED')
|
||||
allocate(amg_s_parmatch_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_s_base_onelev_csetc
|
||||
end subroutine amg_s_base_onelev_csetc
|
||||
end submodule amg_s_base_onelev_csetc_impl
|
||||
|
||||
@@ -35,235 +35,239 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_cseti_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_cseti
|
||||
use amg_s_base_aggregator_mod
|
||||
use amg_s_dec_aggregator_mod
|
||||
use amg_s_symdec_aggregator_mod
|
||||
use amg_s_parmatch_aggregator_mod
|
||||
use amg_s_jac_smoother
|
||||
use amg_s_as_smoother
|
||||
use amg_s_diag_solver
|
||||
use amg_s_l1_diag_solver
|
||||
use amg_s_ilu_solver
|
||||
use amg_s_id_solver
|
||||
use amg_s_gs_solver
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_base_aggregator_mod
|
||||
use amg_s_dec_aggregator_mod
|
||||
use amg_s_symdec_aggregator_mod
|
||||
use amg_s_parmatch_aggregator_mod
|
||||
use amg_s_jac_smoother
|
||||
use amg_s_as_smoother
|
||||
use amg_s_diag_solver
|
||||
use amg_s_l1_diag_solver
|
||||
use amg_s_ilu_solver
|
||||
use amg_s_id_solver
|
||||
use amg_s_gs_solver
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
use amg_s_slu_solver
|
||||
use amg_s_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_s_mumps_solver
|
||||
use amg_s_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_cseti'
|
||||
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
|
||||
type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold
|
||||
type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold
|
||||
type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold
|
||||
type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold
|
||||
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
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_cseti'
|
||||
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
|
||||
type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold
|
||||
type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold
|
||||
type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold
|
||||
type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold
|
||||
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
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold
|
||||
type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold
|
||||
type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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 (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_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 (amg_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)
|
||||
|
||||
case (amg_as_)
|
||||
call lv%set(amg_s_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_s_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_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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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('SUB_SOLVE')
|
||||
select case (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_s_id_solver_mold,info,pos=pos)
|
||||
case (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_s_diag_solver_mold,info,pos=pos)
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_l1_diag_scale_)
|
||||
call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
|
||||
case (amg_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 (amg_gs_)
|
||||
call lv%set(amg_s_gs_solver_mold,info,pos=pos)
|
||||
case (amg_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)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_s_bwgs_solver_mold,info,pos=pos)
|
||||
case (amg_as_)
|
||||
call lv%set(amg_s_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_s_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_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 :)
|
||||
!
|
||||
end select
|
||||
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 (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_s_id_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_s_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_l1_diag_scale_)
|
||||
call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_gs_)
|
||||
call lv%set(amg_s_gs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_s_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_s_slu_solver_mold,info,pos=pos)
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_s_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_s_mumps_solver_mold,info,pos=pos)
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_s_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_s_base_onelev_cseti
|
||||
end subroutine amg_s_base_onelev_cseti
|
||||
end submodule amg_s_base_onelev_cseti_impl
|
||||
|
||||
@@ -35,71 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_csetr_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_csetr
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_csetr'
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
select case (psb_toupper(what))
|
||||
select case (psb_toupper(what))
|
||||
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
|
||||
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
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
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
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_s_base_onelev_csetr
|
||||
end subroutine amg_s_base_onelev_csetr
|
||||
end submodule amg_s_base_onelev_csetr_impl
|
||||
|
||||
@@ -42,114 +42,116 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_descr_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_descr
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_s_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_s_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_s_base_onelev_descr
|
||||
end subroutine amg_s_base_onelev_descr
|
||||
end submodule amg_s_base_onelev_descr_impl
|
||||
|
||||
@@ -35,135 +35,137 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_dump_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_dump
|
||||
implicit none
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_s"
|
||||
end if
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_s"
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_dump
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_dump
|
||||
end submodule amg_s_base_onelev_dump_impl
|
||||
|
||||
@@ -35,41 +35,43 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_free(lv,info)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_free_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_free
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
|
||||
call lv%nullify()
|
||||
call lv%nullify()
|
||||
|
||||
end subroutine amg_s_base_onelev_free
|
||||
end subroutine amg_s_base_onelev_free
|
||||
end submodule amg_s_base_onelev_free_impl
|
||||
|
||||
@@ -35,26 +35,28 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_free_smoothers(lv,info)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_dree_smoothers_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_free_smoothers
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_s_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
end subroutine amg_s_base_onelev_free_smoothers
|
||||
end subroutine amg_s_base_onelev_free_smoothers
|
||||
end submodule amg_s_base_onelev_dree_smoothers_impl
|
||||
|
||||
@@ -35,112 +35,113 @@
|
||||
! 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
|
||||
|
||||
type(psb_s_vect_type), pointer :: vtx_
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_map_prol_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
type(psb_s_vect_type), pointer :: vtx_
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: me, np, rme, rnp
|
||||
real(psb_spk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_s_vect_type) :: tv
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
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)
|
||||
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()
|
||||
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)
|
||||
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)
|
||||
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,mold=vect_u%v)
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v)
|
||||
!!$ 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 psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx_,vty=vty)
|
||||
end associate
|
||||
call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
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
|
||||
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
|
||||
|
||||
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(:)
|
||||
end subroutine amg_s_base_onelev_map_prol_v
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
module subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
real(psb_spk_), intent(inout) :: u(:)
|
||||
real(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_s_base_onelev_map_prol_impl
|
||||
|
||||
@@ -36,114 +36,115 @@
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_map_rstr_impl
|
||||
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
|
||||
type(psb_s_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
type(psb_s_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
type(psb_s_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
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, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context map rstr',rme,rnp,me,np
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
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,mold=vect_u%v)
|
||||
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,mold=vect_u%v)
|
||||
!!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
|
||||
!!$ & psb_errstatus_fatal()
|
||||
!!$ flush(0)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
!!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
|
||||
call psb_snd(ctxt,tv%v%v(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
call psb_snd(ctxt,tv%v%v(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)
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()
|
||||
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
|
||||
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 ',psb_errstatus_fatal()
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) me,' map_rstr calling U2V: ',me,np
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
!!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()
|
||||
end subroutine amg_s_base_onelev_map_rstr_v
|
||||
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(:)
|
||||
module subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
real(psb_spk_), intent(in) :: alpha, beta
|
||||
real(psb_spk_), intent(inout) :: u(:)
|
||||
real(psb_spk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_s_base_onelev_map_rstr_impl
|
||||
|
||||
@@ -83,109 +83,111 @@
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_mat_asb_impl
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_mat_asb
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout), target :: lv
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_sspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
implicit none
|
||||
|
||||
name='amg_s_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(inout), target :: lv
|
||||
type(psb_sspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_lsspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_sspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
name='amg_s_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega)
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_s_base_onelev_mat_asb
|
||||
end subroutine amg_s_base_onelev_mat_asb
|
||||
end submodule amg_s_base_onelev_mat_asb_impl
|
||||
|
||||
@@ -42,109 +42,112 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_memory_use_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_memory_use
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_s_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity,prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_s_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
endif
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
end if
|
||||
endif
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_s_base_onelev_memory_use
|
||||
end subroutine amg_s_base_onelev_memory_use
|
||||
end submodule amg_s_base_onelev_memory_use_impl
|
||||
|
||||
@@ -35,48 +35,50 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_setag_impl
|
||||
use psb_base_mod
|
||||
use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_setag
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_s_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
info = psb_success_
|
||||
implicit none
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_s_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_setag
|
||||
|
||||
end subroutine amg_s_base_onelev_setag
|
||||
|
||||
end submodule amg_s_base_onelev_setag_impl
|
||||
|
||||
@@ -35,72 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_setsm(lev,val,info,pos)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_setsm_impl
|
||||
use psb_base_mod
|
||||
use amg_s_prec_mod, amg_protect_name => amg_s_base_onelev_setsm
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_s_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_setsm(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_s_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lev%sm2a)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
lev%sm2 => null()
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lev%sm)) then
|
||||
if (.not.same_type_as(lev%sm,val)) then
|
||||
call lev%sm%free(info)
|
||||
deallocate(lev%sm, stat=info)
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
lv%sm2 => null()
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lev%sm)) then
|
||||
allocate(lev%sm,mold=val)
|
||||
end if
|
||||
call lev%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (.not.same_type_as(lev%sm2a,val)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a)) then
|
||||
allocate(lev%sm2a,mold=val)
|
||||
end if
|
||||
call lev%sm2a%default()
|
||||
lev%sm2 => lev%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_s_base_onelev_setsm
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lv%sm)) then
|
||||
if (.not.same_type_as(lv%sm,val)) then
|
||||
call lv%sm%free(info)
|
||||
deallocate(lv%sm, stat=info)
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lv%sm)) then
|
||||
allocate(lv%sm,mold=val)
|
||||
end if
|
||||
call lv%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (.not.same_type_as(lv%sm2a,val)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a)) then
|
||||
allocate(lv%sm2a,mold=val)
|
||||
end if
|
||||
call lv%sm2a%default()
|
||||
lv%sm2 => lv%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_s_base_onelev_setsm
|
||||
|
||||
end submodule amg_s_base_onelev_setsm_impl
|
||||
|
||||
@@ -35,110 +35,111 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_base_onelev_setsv(lev,val,info,pos)
|
||||
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_setsv_impl
|
||||
use psb_base_mod
|
||||
use amg_s_prec_mod, amg_protect_name => amg_s_base_onelev_setsv
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_s_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
contains
|
||||
module subroutine amg_s_base_onelev_setsv(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
info = psb_success_
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_s_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lev%sm)) then
|
||||
if (allocated(lev%sm%sv)) then
|
||||
if (.not.same_type_as(lev%sm%sv,val)) then
|
||||
call lev%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm%sv,stat=info)
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if (allocated(lv%sm%sv)) then
|
||||
if (.not.same_type_as(lv%sm%sv,val)) then
|
||||
call lv%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
allocate(lv%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lv%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
if (.not.allocated(lev%sm%sv)) then
|
||||
allocate(lev%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
end if
|
||||
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then
|
||||
|
||||
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (allocated(lev%sm2a%sv)) then
|
||||
if (.not.same_type_as(lev%sm2a%sv,val)) then
|
||||
call lev%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm2a%sv,stat=info)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (allocated(lv%sm2a%sv)) then
|
||||
if (.not.same_type_as(lv%sm2a%sv,val)) then
|
||||
call lv%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm2a%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a%sv)) then
|
||||
allocate(lv%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a%sv)) then
|
||||
allocate(lev%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_setsv
|
||||
call lv%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_s_base_onelev_setsv
|
||||
|
||||
end submodule amg_s_base_onelev_setsv_impl
|
||||
|
||||
@@ -0,0 +1,333 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific prior written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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.
|
||||
!
|
||||
!
|
||||
submodule (amg_s_onelev_mod) amg_s_base_onelev_wrk_handle_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
|
||||
module subroutine s_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine s_base_onelev_move_alloc
|
||||
|
||||
module subroutine s_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
module subroutine s_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_s_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine s_base_onelev_free_wrk
|
||||
|
||||
module subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call s_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call s_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call s_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call s_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
end subroutine s_wrk_alloc
|
||||
|
||||
module subroutine s_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine s_inner_do_wrk_alloc
|
||||
|
||||
|
||||
module subroutine s_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine s_wrk_free
|
||||
|
||||
module subroutine s_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine s_wrk_clone
|
||||
|
||||
module subroutine s_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine s_wrk_move_alloc
|
||||
|
||||
module subroutine s_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_smlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine s_wrk_cnv
|
||||
|
||||
module function s_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_smlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
end if
|
||||
end function s_wrk_sizeof
|
||||
|
||||
module subroutine s_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
|
||||
module subroutine s_remap_move_alloc(rmp, remap_out, info)
|
||||
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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine s_remap_move_alloc
|
||||
|
||||
end submodule amg_s_base_onelev_wrk_handle_impl
|
||||
@@ -35,129 +35,132 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_build_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_build
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
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
|
||||
integer(psb_ipk_), intent(in), optional :: ilv
|
||||
! Local
|
||||
integer(psb_ipk_) :: err,i,k, err_act
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Unassociated base DESC')
|
||||
goto 9999
|
||||
end if
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
name = 'amg_onelev_build'
|
||||
info=psb_success_
|
||||
err=0
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; 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
|
||||
end if
|
||||
end if
|
||||
if (info /=0 ) then
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
if (.not.associated(lv%base_desc)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='Smoother bld error')
|
||||
& a_err='Unassociated base DESC')
|
||||
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 '
|
||||
info = psb_success_
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
!
|
||||
! 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
|
||||
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
|
||||
end if
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) &
|
||||
& call lv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_z_base_onelev_build
|
||||
end subroutine amg_z_base_onelev_build
|
||||
end submodule amg_z_base_onelev_build_impl
|
||||
|
||||
@@ -35,59 +35,60 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_check(lv,info)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_check_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_check
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_z_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_z_base_smoother_type), intent(in), target :: sm
|
||||
module subroutine amg_z_base_onelev_check(lv,info)
|
||||
Implicit None
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_z_base_onelev_check
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_base_onelev_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(lv%parms%sweeps_pre,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
call amg_check_def(lv%parms%sweeps_post,&
|
||||
& 'Jacobi sweeps',ione,is_int_non_negative)
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%check(info)
|
||||
else
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%check(info)
|
||||
else if (.not.inner_check(lv%sm2,lv%sm)) then
|
||||
info=3111
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
contains
|
||||
function inner_check(smp,sm) result(res)
|
||||
implicit none
|
||||
logical :: res
|
||||
class(amg_z_base_smoother_type), intent(in), pointer :: smp
|
||||
class(amg_z_base_smoother_type), intent(in), target :: sm
|
||||
|
||||
res = associated(smp, sm)
|
||||
end function inner_check
|
||||
|
||||
end subroutine amg_z_base_onelev_check
|
||||
end submodule amg_z_base_onelev_check_impl
|
||||
|
||||
@@ -35,33 +35,36 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_cnv_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_cnv
|
||||
implicit none
|
||||
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_z_base_onelev_cnv
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
|
||||
implicit none
|
||||
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
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
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (any((/present(amold),present(vmold),present(imold)/))) then
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info == psb_success_ .and. allocated(lv%wrk)) &
|
||||
& call lv%wrk%cnv(info,vmold=vmold)
|
||||
if (info == psb_success_.and. lv%ac%is_asb()) &
|
||||
& 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%linmap%cnv(info,mold=amold,imold=imold)
|
||||
end if
|
||||
end subroutine amg_z_base_onelev_cnv
|
||||
end submodule amg_z_base_onelev_cnv_impl
|
||||
|
||||
@@ -35,297 +35,301 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_csetc_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_csetc
|
||||
use amg_z_base_aggregator_mod
|
||||
use amg_z_dec_aggregator_mod
|
||||
use amg_z_symdec_aggregator_mod
|
||||
use amg_z_jac_smoother
|
||||
use amg_z_as_smoother
|
||||
use amg_z_diag_solver
|
||||
use amg_z_l1_diag_solver
|
||||
use amg_z_jac_solver
|
||||
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
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_z_base_aggregator_mod
|
||||
use amg_z_dec_aggregator_mod
|
||||
use amg_z_symdec_aggregator_mod
|
||||
use amg_z_jac_smoother
|
||||
use amg_z_as_smoother
|
||||
use amg_z_diag_solver
|
||||
use amg_z_l1_diag_solver
|
||||
use amg_z_jac_solver
|
||||
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(AMG_HAVE_UMF)
|
||||
use amg_z_umf_solver
|
||||
use amg_z_umf_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
use amg_z_sludist_solver
|
||||
use amg_z_sludist_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
use amg_z_slu_solver
|
||||
use amg_z_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_z_mumps_solver
|
||||
use amg_z_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_csetc'
|
||||
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
|
||||
type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold
|
||||
type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold
|
||||
type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold
|
||||
type(amg_z_jac_solver_type) :: amg_z_jac_solver_mold
|
||||
type(amg_z_l1_jac_solver_type) :: amg_z_l1_jac_solver_mold
|
||||
type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold
|
||||
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
|
||||
! Arguments
|
||||
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
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_csetc'
|
||||
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
|
||||
type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold
|
||||
type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold
|
||||
type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold
|
||||
type(amg_z_jac_solver_type) :: amg_z_jac_solver_mold
|
||||
type(amg_z_l1_jac_solver_type) :: amg_z_l1_jac_solver_mold
|
||||
type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold
|
||||
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(AMG_HAVE_UMF)
|
||||
type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold
|
||||
type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold
|
||||
type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold
|
||||
type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold
|
||||
type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
ival = lv%stringval(val)
|
||||
ival = lv%stringval(val)
|
||||
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
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)
|
||||
|
||||
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)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(amg_z_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_z_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_z_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_z_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
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('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 ('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)
|
||||
|
||||
case ('DIAG','JACOBI')
|
||||
call lv%set(amg_z_diag_solver_mold,info,pos=pos)
|
||||
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 ('L1-DIAG','L1-JACOBI')
|
||||
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 ('GS','FGS','FWGS')
|
||||
call lv%set(amg_z_gs_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)
|
||||
|
||||
case ('BGS','BWGS')
|
||||
call lv%set(amg_z_bwgs_solver_mold,info,pos=pos)
|
||||
case ('AS')
|
||||
call lv%set(amg_z_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_ilu_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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_z_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(amg_z_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)
|
||||
case ('FBGS')
|
||||
call lv%set(amg_z_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_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
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')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
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)
|
||||
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 :)
|
||||
!
|
||||
end select
|
||||
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','JACOBI')
|
||||
call lv%set(amg_z_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI')
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case ('SLU')
|
||||
call lv%set(amg_z_slu_solver_mold,info,pos=pos)
|
||||
case ('SLU')
|
||||
call lv%set(amg_z_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_z_mumps_solver_mold,info,pos=pos)
|
||||
case ('MUMPS')
|
||||
call lv%set(amg_z_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_SLUDIST
|
||||
case ('SLUDIST')
|
||||
call lv%set(amg_z_sludist_solver_mold,info,pos=pos)
|
||||
case ('SLUDIST')
|
||||
call lv%set(amg_z_sludist_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_UMF
|
||||
case ('UMF')
|
||||
call lv%set(amg_z_umf_solver_mold,info,pos=pos)
|
||||
case ('UMF')
|
||||
call lv%set(amg_z_umf_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = amg_stringval(val)
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
case ('PAR_AGGR_ALG')
|
||||
ival = amg_stringval(val)
|
||||
lv%parms%par_aggr_alg = ival
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='aggregator deallocation?')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
select case(val)
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = amg_stringval(val)
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = amg_stringval(val)
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = amg_stringval(val)
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = amg_stringval(val)
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= amg_stringval(val)
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = amg_stringval(val)
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = amg_stringval(val)
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
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
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_z_base_onelev_csetc
|
||||
end subroutine amg_z_base_onelev_csetc
|
||||
end submodule amg_z_base_onelev_csetc_impl
|
||||
|
||||
@@ -35,254 +35,258 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_cseti_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_cseti
|
||||
use amg_z_base_aggregator_mod
|
||||
use amg_z_dec_aggregator_mod
|
||||
use amg_z_symdec_aggregator_mod
|
||||
use amg_z_jac_smoother
|
||||
use amg_z_as_smoother
|
||||
use amg_z_diag_solver
|
||||
use amg_z_l1_diag_solver
|
||||
use amg_z_ilu_solver
|
||||
use amg_z_id_solver
|
||||
use amg_z_gs_solver
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_z_base_aggregator_mod
|
||||
use amg_z_dec_aggregator_mod
|
||||
use amg_z_symdec_aggregator_mod
|
||||
use amg_z_jac_smoother
|
||||
use amg_z_as_smoother
|
||||
use amg_z_diag_solver
|
||||
use amg_z_l1_diag_solver
|
||||
use amg_z_ilu_solver
|
||||
use amg_z_id_solver
|
||||
use amg_z_gs_solver
|
||||
#if defined(AMG_HAVE_UMF)
|
||||
use amg_z_umf_solver
|
||||
use amg_z_umf_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
use amg_z_sludist_solver
|
||||
use amg_z_sludist_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
use amg_z_slu_solver
|
||||
use amg_z_slu_solver
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
use amg_z_mumps_solver
|
||||
use amg_z_mumps_solver
|
||||
#endif
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_cseti'
|
||||
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
|
||||
type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold
|
||||
type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold
|
||||
type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold
|
||||
type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold
|
||||
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
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_cseti'
|
||||
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
|
||||
type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold
|
||||
type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold
|
||||
type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold
|
||||
type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold
|
||||
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
|
||||
#if defined(AMG_HAVE_UMF)
|
||||
type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold
|
||||
type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLUDIST)
|
||||
type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold
|
||||
type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_SLU)
|
||||
type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold
|
||||
type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold
|
||||
#endif
|
||||
#if defined(AMG_HAVE_MUMPS)
|
||||
type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold
|
||||
type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold
|
||||
#endif
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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 (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_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 (amg_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)
|
||||
|
||||
case (amg_as_)
|
||||
call lv%set(amg_z_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_z_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_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 :)
|
||||
!
|
||||
end select
|
||||
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
|
||||
|
||||
select case (psb_toupper(what))
|
||||
case ('SMOOTHER_TYPE')
|
||||
select case (val)
|
||||
case (amg_noprec_)
|
||||
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('SUB_SOLVE')
|
||||
select case (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_z_id_solver_mold,info,pos=pos)
|
||||
case (amg_jac_)
|
||||
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)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_z_diag_solver_mold,info,pos=pos)
|
||||
case (amg_l1_jac_)
|
||||
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 (amg_l1_diag_scale_)
|
||||
call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos)
|
||||
case (amg_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 (amg_gs_)
|
||||
call lv%set(amg_z_gs_solver_mold,info,pos=pos)
|
||||
case (amg_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)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_z_bwgs_solver_mold,info,pos=pos)
|
||||
case (amg_as_)
|
||||
call lv%set(amg_z_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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
|
||||
case (amg_fbgs_)
|
||||
call lv%set(amg_z_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_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 :)
|
||||
!
|
||||
end select
|
||||
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 (val)
|
||||
case (amg_f_none_)
|
||||
call lv%set(amg_z_id_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_diag_scale_)
|
||||
call lv%set(amg_z_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_l1_diag_scale_)
|
||||
call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_gs_)
|
||||
call lv%set(amg_z_gs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_z_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
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
|
||||
call lv%sm%sv%set('SUB_SOLVE',val,info)
|
||||
end if
|
||||
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 AMG_HAVE_SLU
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_z_slu_solver_mold,info,pos=pos)
|
||||
case (amg_slu_)
|
||||
call lv%set(amg_z_slu_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_MUMPS
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_z_mumps_solver_mold,info,pos=pos)
|
||||
case (amg_mumps_)
|
||||
call lv%set(amg_z_mumps_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_SLUDIST
|
||||
case (amg_sludist_)
|
||||
call lv%set(amg_z_sludist_solver_mold,info,pos=pos)
|
||||
case (amg_sludist_)
|
||||
call lv%set(amg_z_sludist_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
#ifdef AMG_HAVE_UMF
|
||||
case (amg_umf_)
|
||||
call lv%set(amg_z_umf_solver_mold,info,pos=pos)
|
||||
case (amg_umf_)
|
||||
call lv%set(amg_z_umf_solver_mold,info,pos=pos)
|
||||
#endif
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
!
|
||||
! Do nothing and hope for the best :)
|
||||
!
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
|
||||
|
||||
case ('SMOOTHER_SWEEPS')
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_pre = val
|
||||
if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) &
|
||||
& lv%parms%sweeps_post = val
|
||||
|
||||
case ('ML_CYCLE')
|
||||
lv%parms%ml_cycle = val
|
||||
|
||||
case ('PAR_AGGR_ALG')
|
||||
lv%parms%par_aggr_alg = val
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%free(info)
|
||||
if (info == 0) deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
return
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case(amg_dec_aggr_)
|
||||
allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case(amg_sym_dec_aggr_)
|
||||
allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
if (info == psb_success_) call lv%aggr%default()
|
||||
|
||||
case ('AGGR_ORD')
|
||||
lv%parms%aggr_ord = val
|
||||
|
||||
case ('AGGR_TYPE')
|
||||
lv%parms%aggr_type = val
|
||||
if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info)
|
||||
|
||||
case ('AGGR_PROL')
|
||||
lv%parms%aggr_prol = val
|
||||
|
||||
case ('COARSE_MAT')
|
||||
lv%parms%coarse_mat = val
|
||||
|
||||
case ('AGGR_OMEGA_ALG')
|
||||
lv%parms%aggr_omega_alg= val
|
||||
|
||||
case ('AGGR_EIG')
|
||||
lv%parms%aggr_eig = val
|
||||
|
||||
case ('AGGR_FILTER')
|
||||
lv%parms%aggr_filter = val
|
||||
|
||||
case ('COARSE_SOLVE')
|
||||
lv%parms%coarse_solve = val
|
||||
|
||||
case default
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
end if
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_z_base_onelev_cseti
|
||||
end subroutine amg_z_base_onelev_cseti
|
||||
end submodule amg_z_base_onelev_cseti_impl
|
||||
|
||||
@@ -35,71 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_csetr_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_csetr
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_csetr'
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
select case (psb_toupper(what))
|
||||
select case (psb_toupper(what))
|
||||
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
case ('AGGR_OMEGA_VAL')
|
||||
lv%parms%aggr_omega_val= val
|
||||
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
case ('AGGR_THRESH')
|
||||
lv%parms%aggr_thresh = val
|
||||
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
case default
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
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
|
||||
call lv%sm2a%set(what,val,info,idx=idx)
|
||||
|
||||
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
|
||||
end if
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
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
|
||||
if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx)
|
||||
|
||||
end select
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
if (info /= psb_success_) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_z_base_onelev_csetr
|
||||
end subroutine amg_z_base_onelev_csetr
|
||||
end submodule amg_z_base_onelev_csetr_impl
|
||||
|
||||
@@ -42,114 +42,116 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_descr_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_descr
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_z_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_z_base_onelev_descr'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse
|
||||
character(1024) :: prefix_
|
||||
type(psb_ctxt_type) :: pctxt
|
||||
integer(psb_ipk_) :: pme, pnp
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
pctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(pctxt,pme,pnp)
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
write(iout_,*) 'At level :',il,' we have ',pnp,' processes'
|
||||
write(iout_,*) trim(prefix_)
|
||||
if (il == ilmin) then
|
||||
call lv%parms%mlcycledsc(iout_,info)
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then
|
||||
if (allocated(lv%aggr)) then
|
||||
call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix)
|
||||
else
|
||||
write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object'
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
write(iout_,*) trim(prefix_)
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
if (il > 1) then
|
||||
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
|
||||
call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix)
|
||||
|
||||
if (nl > 1) then
|
||||
if (allocated(lv%linmap%naggr)) then
|
||||
write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', &
|
||||
& lv%linmap%nagtot
|
||||
write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot
|
||||
if (verbosity_>0) then
|
||||
write(iout_,*) trim(prefix_), ' Local matrix sizes: ', &
|
||||
& lv%linmap%naggr(:)
|
||||
else
|
||||
write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),&
|
||||
& ' Local matrix sizes: min:', &
|
||||
& lv%linmap%nagmin,' max:', lv%linmap%nagmax
|
||||
write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),&
|
||||
& ' avg:', &
|
||||
& lv%linmap%nagavg
|
||||
end if
|
||||
write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),&
|
||||
& ' Aggregation ratio: ', &
|
||||
& lv%szratio
|
||||
end if
|
||||
end if
|
||||
|
||||
if (coarse.and.allocated(lv%sm)) &
|
||||
& call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_z_base_onelev_descr
|
||||
end subroutine amg_z_base_onelev_descr
|
||||
end submodule amg_z_base_onelev_descr_impl
|
||||
|
||||
@@ -35,135 +35,137 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_dump_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_dump
|
||||
implicit none
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_z"
|
||||
end if
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
& smoother,solver,tprol,global_num)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_, frmt
|
||||
character(len=1024) :: fname
|
||||
logical :: ac_, rp_, tprol_, global_num_
|
||||
integer(psb_lpk_), allocatable :: ivr(:), ivc(:)
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_lev_z"
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
|
||||
if (associated(lv%base_desc)) then
|
||||
ctxt = lv%base_desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
else
|
||||
iam = -1
|
||||
np = -1
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_dump
|
||||
if (present(ac)) then
|
||||
ac_ = ac
|
||||
else
|
||||
ac_ = .false.
|
||||
end if
|
||||
if (present(rp)) then
|
||||
rp_ = rp
|
||||
else
|
||||
rp_ = .false.
|
||||
end if
|
||||
if (present(tprol)) then
|
||||
tprol_ = tprol
|
||||
else
|
||||
tprol_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
|
||||
if (np > 0) then
|
||||
ni = floor(log10(1.0*np)) + 1
|
||||
write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')'
|
||||
write(fname(lname+1:lname+ni+2),frmt) '_p',iam
|
||||
lname = lname + ni + 2
|
||||
end if
|
||||
|
||||
if (global_num_) then
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
ivr = lv%base_desc%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
ivr = lv%desc_ac%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head,iv=ivr)
|
||||
end if
|
||||
if (rp_) then
|
||||
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%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%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%linmap%p_desc_U%get_global_indices(owned=.false.)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head,ivr=ivr)
|
||||
end if
|
||||
end if
|
||||
else
|
||||
if (level == 1) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%base_a%print(fname,head=head)
|
||||
end if
|
||||
else if (level >= 2) then
|
||||
if (ac_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx'
|
||||
call lv%ac%print(fname,head=head)
|
||||
end if
|
||||
if (rp_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx'
|
||||
call lv%linmap%mat_U2V%print(fname,head=head)
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx'
|
||||
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'
|
||||
!
|
||||
call lv%tprol%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (level >= 1) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num)
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_dump
|
||||
end submodule amg_z_base_onelev_dump_impl
|
||||
|
||||
@@ -35,41 +35,43 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_free(lv,info)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_free_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_free
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_free(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
if (allocated(lv%wrk)) &
|
||||
& call lv%wrk%free(info)
|
||||
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
call lv%ac%free()
|
||||
if (lv%desc_ac%is_ok()) &
|
||||
& call lv%desc_ac%free(info)
|
||||
call lv%linmap%free(info)
|
||||
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_a)
|
||||
! This is a pointer to something else, must not free it here.
|
||||
nullify(lv%base_desc)
|
||||
|
||||
call lv%nullify()
|
||||
call lv%nullify()
|
||||
|
||||
end subroutine amg_z_base_onelev_free
|
||||
end subroutine amg_z_base_onelev_free
|
||||
end submodule amg_z_base_onelev_free_impl
|
||||
|
||||
@@ -35,26 +35,28 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_free_smoothers(lv,info)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_dree_smoothers_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_free_smoothers
|
||||
implicit none
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_free_smoothers(lv,info)
|
||||
implicit none
|
||||
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
class(amg_z_onelev_type), intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
info = psb_success_
|
||||
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
! We might just deallocate the top level array, except
|
||||
! that there may be inner objects containing C pointers,
|
||||
! e.g. UMFPACK, SLU or CUDA stuff.
|
||||
! We really need FINALs.
|
||||
if (allocated(lv%sm)) &
|
||||
& call lv%sm%free(info)
|
||||
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
if (allocated(lv%sm2a)) &
|
||||
& call lv%sm2a%free(info)
|
||||
|
||||
end subroutine amg_z_base_onelev_free_smoothers
|
||||
end subroutine amg_z_base_onelev_free_smoothers
|
||||
end submodule amg_z_base_onelev_dree_smoothers_impl
|
||||
|
||||
@@ -35,112 +35,113 @@
|
||||
! 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
|
||||
|
||||
type(psb_z_vect_type), pointer :: vtx_
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_map_prol_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
|
||||
type(psb_z_vect_type), pointer :: vtx_
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: me, np, rme, rnp
|
||||
complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:)
|
||||
type(psb_z_vect_type) :: tv
|
||||
if (present(vtx)) then
|
||||
vtx_ => vtx
|
||||
else
|
||||
vtx_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ 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_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
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)
|
||||
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()
|
||||
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)
|
||||
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)
|
||||
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,mold=vect_u%v)
|
||||
|
||||
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v)
|
||||
!!$ 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 psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,&
|
||||
& work=work,vtx=vtx_,vty=vty)
|
||||
end associate
|
||||
call psb_rcv(ctxt,tv%v%v(1:nrl),idest)
|
||||
call tv%set_host()
|
||||
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
|
||||
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
|
||||
|
||||
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(:)
|
||||
end subroutine amg_z_base_onelev_map_prol_v
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
module subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
complex(psb_dpk_), intent(inout) :: u(:)
|
||||
complex(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap P handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_z_base_onelev_map_prol_impl
|
||||
|
||||
@@ -36,114 +36,115 @@
|
||||
!
|
||||
!
|
||||
|
||||
subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_map_rstr_impl
|
||||
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
|
||||
type(psb_z_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
|
||||
& work,vtx,vty)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
type(psb_z_vect_type), intent(inout) :: vect_u, vect_v
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
|
||||
type(psb_z_vect_type), pointer :: vty_
|
||||
integer(psb_mpk_) :: me, np
|
||||
|
||||
!!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb()
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
if (present(vty)) then
|
||||
vty_ => vty
|
||||
else
|
||||
vty_ => lv%wrk%wv(1)
|
||||
end if
|
||||
|
||||
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, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
|
||||
integer(psb_mpk_) :: 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)
|
||||
rctxt = lv%desc_ac%get_ctxt()
|
||||
call psb_info(rctxt,rme,rnp)
|
||||
!!$ write(0,*) 'New context map rstr',rme,rnp,me,np
|
||||
idest = lv%remap_data%idest
|
||||
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
|
||||
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,mold=vect_u%v)
|
||||
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,mold=vect_u%v)
|
||||
!!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
|
||||
!!$ & psb_errstatus_fatal()
|
||||
!!$ flush(0)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
call psb_barrier(ctxt)
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
call tv%sync()
|
||||
!rsnd = tv%get_vect()
|
||||
!call psb_snd(ctxt,rsnd(1:nrl),idest)
|
||||
!!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
|
||||
call psb_snd(ctxt,tv%v%v(1:nrl),idest)
|
||||
if (rme >=0) then
|
||||
allocate(rrcv(sum(nrsrc)))
|
||||
call psb_snd(ctxt,tv%v%v(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)
|
||||
kp = 0
|
||||
do i = 1,size(isrc)
|
||||
ip = isrc(i)
|
||||
nrl = nrsrc(i)
|
||||
!!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()
|
||||
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
|
||||
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 ',psb_errstatus_fatal()
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
end block
|
||||
|
||||
else
|
||||
! Default transfer
|
||||
block
|
||||
type(psb_ctxt_type) :: ctxt, rctxt
|
||||
ctxt = lv%linmap%p_desc_U%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
!!$ write(0,*) me,' map_rstr calling U2V: ',me,np
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
|
||||
& work=work,vtx=vtx,vty=vty_)
|
||||
end block
|
||||
end if
|
||||
!!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()
|
||||
end subroutine amg_z_base_onelev_map_rstr_v
|
||||
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(:)
|
||||
module subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
complex(psb_dpk_), intent(in) :: alpha, beta
|
||||
complex(psb_dpk_), intent(inout) :: u(:)
|
||||
complex(psb_dpk_), intent(out) :: v(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), optional :: work(:)
|
||||
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
if (lv%remap_data%ac_pre_remap%is_asb()) then
|
||||
!
|
||||
! Remap has happened, deal with it
|
||||
!
|
||||
write(0,*) 'Remap R handling not implemented yet for A'
|
||||
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
|
||||
end submodule amg_z_base_onelev_map_rstr_impl
|
||||
|
||||
@@ -83,109 +83,111 @@
|
||||
! info - integer, output.
|
||||
! Error code.
|
||||
!
|
||||
subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_mat_asb_impl
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_mat_asb
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout), target :: lv
|
||||
type(psb_zspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_lzspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_zspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
implicit none
|
||||
|
||||
name='amg_z_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega)
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(inout), target :: lv
|
||||
type(psb_zspmat_type), intent(in) :: a
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer(psb_lpk_), intent(inout) :: nlaggr(:)
|
||||
integer(psb_lpk_), intent(inout) :: ilaggr(:)
|
||||
type(psb_lzspmat_type), intent(inout) :: t_prol
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
! Local variables
|
||||
character(len=24) :: name
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: err_act
|
||||
type(psb_zspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
name='amg_z_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
if (psb_errstatus_fatal()) then
|
||||
info = psb_err_internal_error_; goto 9999
|
||||
end if
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',&
|
||||
& amg_distr_mat_,is_legal_ml_coarse_mat)
|
||||
call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',&
|
||||
& amg_no_filter_mat_,is_legal_aggr_filter)
|
||||
call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',&
|
||||
& amg_eig_est_,is_legal_ml_aggr_omega_alg)
|
||||
call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',&
|
||||
& amg_max_norm_,is_legal_ml_aggr_eig)
|
||||
call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega)
|
||||
|
||||
|
||||
!
|
||||
! Build the coarse-level matrix from the fine-level one, starting from
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
end if
|
||||
!
|
||||
! Fix the base_a and base_desc pointers for handling of residuals.
|
||||
! This is correct because this routine is only called at levels >=2.
|
||||
!
|
||||
lv%base_a => lv%ac
|
||||
lv%base_desc => lv%desc_ac
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_z_base_onelev_mat_asb
|
||||
end subroutine amg_z_base_onelev_mat_asb
|
||||
end submodule amg_z_base_onelev_mat_asb_impl
|
||||
|
||||
@@ -42,109 +42,112 @@
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_memory_use_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_memory_use
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_z_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,&
|
||||
& iout,verbosity,prefix,global)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_z_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
endif
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
end if
|
||||
endif
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine amg_z_base_onelev_memory_use
|
||||
end subroutine amg_z_base_onelev_memory_use
|
||||
end submodule amg_z_base_onelev_memory_use_impl
|
||||
|
||||
@@ -35,48 +35,50 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_setag_impl
|
||||
use psb_base_mod
|
||||
use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_setag
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_z_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_setag(lv,val,info,pos)
|
||||
|
||||
info = psb_success_
|
||||
implicit none
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_z_base_aggregator_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setag'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
! Ignore pos for aggregator
|
||||
|
||||
if (allocated(lv%aggr)) then
|
||||
if (.not.same_type_as(lv%aggr,val)) then
|
||||
call lv%aggr%free(info)
|
||||
deallocate(lv%aggr,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%aggr)) then
|
||||
allocate(lv%aggr,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
lv%parms%par_aggr_alg = amg_ext_aggr_
|
||||
lv%parms%aggr_type = amg_noalg_
|
||||
call lv%aggr%default()
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_setag
|
||||
|
||||
end subroutine amg_z_base_onelev_setag
|
||||
|
||||
end submodule amg_z_base_onelev_setag_impl
|
||||
|
||||
@@ -35,72 +35,73 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_setsm(lev,val,info,pos)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_setsm_impl
|
||||
use psb_base_mod
|
||||
use amg_z_prec_mod, amg_protect_name => amg_z_base_onelev_setsm
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_z_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_setsm(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_z_base_smoother_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsm'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lev%sm2a)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
lev%sm2 => null()
|
||||
end if
|
||||
end if
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lev%sm)) then
|
||||
if (.not.same_type_as(lev%sm,val)) then
|
||||
call lev%sm%free(info)
|
||||
deallocate(lev%sm, stat=info)
|
||||
|
||||
if (ipos_ == amg_smooth_both_) then
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
lv%sm2 => null()
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lev%sm)) then
|
||||
allocate(lev%sm,mold=val)
|
||||
end if
|
||||
call lev%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (.not.same_type_as(lev%sm2a,val)) then
|
||||
call lev%sm2a%free(info)
|
||||
deallocate(lev%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a)) then
|
||||
allocate(lev%sm2a,mold=val)
|
||||
end if
|
||||
call lev%sm2a%default()
|
||||
lev%sm2 => lev%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_z_base_onelev_setsm
|
||||
|
||||
select case(ipos_)
|
||||
case(amg_smooth_pre_, amg_smooth_both_)
|
||||
if (allocated(lv%sm)) then
|
||||
if (.not.same_type_as(lv%sm,val)) then
|
||||
call lv%sm%free(info)
|
||||
deallocate(lv%sm, stat=info)
|
||||
end if
|
||||
endif
|
||||
if (.not.allocated(lv%sm)) then
|
||||
allocate(lv%sm,mold=val)
|
||||
end if
|
||||
call lv%sm%default()
|
||||
if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm
|
||||
case(amg_smooth_post_)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (.not.same_type_as(lv%sm2a,val)) then
|
||||
call lv%sm2a%free(info)
|
||||
deallocate(lv%sm2a, stat=info)
|
||||
endif
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a)) then
|
||||
allocate(lv%sm2a,mold=val)
|
||||
end if
|
||||
call lv%sm2a%default()
|
||||
lv%sm2 => lv%sm2a
|
||||
end select
|
||||
|
||||
end subroutine amg_z_base_onelev_setsm
|
||||
|
||||
end submodule amg_z_base_onelev_setsm_impl
|
||||
|
||||
@@ -35,110 +35,111 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_z_base_onelev_setsv(lev,val,info,pos)
|
||||
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_setsv_impl
|
||||
use psb_base_mod
|
||||
use amg_z_prec_mod, amg_protect_name => amg_z_base_onelev_setsv
|
||||
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lev
|
||||
class(amg_z_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
contains
|
||||
module subroutine amg_z_base_onelev_setsv(lv,val,info,pos)
|
||||
implicit none
|
||||
|
||||
info = psb_success_
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
class(amg_z_base_solver_type), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), optional, intent(in) :: pos
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ipos_
|
||||
character(len=*), parameter :: name='amg_base_onelev_setsv'
|
||||
|
||||
info = psb_success_
|
||||
|
||||
if (present(pos)) then
|
||||
select case(psb_toupper(trim(pos)))
|
||||
case('PRE')
|
||||
ipos_ = amg_smooth_pre_
|
||||
case('POST')
|
||||
ipos_ = amg_smooth_post_
|
||||
case default
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end select
|
||||
else
|
||||
ipos_ = amg_smooth_both_
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lev%sm)) then
|
||||
if (allocated(lev%sm%sv)) then
|
||||
if (.not.same_type_as(lev%sm%sv,val)) then
|
||||
call lev%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm%sv,stat=info)
|
||||
end if
|
||||
|
||||
if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then
|
||||
if (allocated(lv%sm)) then
|
||||
if (allocated(lv%sm%sv)) then
|
||||
if (.not.same_type_as(lv%sm%sv,val)) then
|
||||
call lv%sm%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
|
||||
if (.not.allocated(lv%sm%sv)) then
|
||||
allocate(lv%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lv%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
if (.not.allocated(lev%sm%sv)) then
|
||||
allocate(lev%sm%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm%sv%default()
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
end if
|
||||
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
!
|
||||
! If POS was not specified and therefore we have amg_smooth_both_
|
||||
! we need to update sm2a *only* if it was already allocated,
|
||||
! otherwise it is not needed (since we have just fixed %sm in the
|
||||
! pre section).
|
||||
!
|
||||
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then
|
||||
if ((ipos_ == amg_smooth_post_).or. &
|
||||
((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then
|
||||
|
||||
|
||||
if (allocated(lev%sm2a)) then
|
||||
if (allocated(lev%sm2a%sv)) then
|
||||
if (.not.same_type_as(lev%sm2a%sv,val)) then
|
||||
call lev%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lev%sm2a%sv,stat=info)
|
||||
if (allocated(lv%sm2a)) then
|
||||
if (allocated(lv%sm2a%sv)) then
|
||||
if (.not.same_type_as(lv%sm2a%sv,val)) then
|
||||
call lv%sm2a%sv%free(info)
|
||||
if (info == 0) deallocate(lv%sm2a%sv,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lv%sm2a%sv)) then
|
||||
allocate(lv%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(lev%sm2a%sv)) then
|
||||
allocate(lev%sm2a%sv,mold=val,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 3111
|
||||
return
|
||||
end if
|
||||
end if
|
||||
call lev%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_setsv
|
||||
call lv%sm2a%sv%default()
|
||||
|
||||
else
|
||||
info = 3111
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Error: uninitialized preconditioner component,',&
|
||||
&' should call amg_PRECINIT/amg_PRECSET'
|
||||
return
|
||||
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
end subroutine amg_z_base_onelev_setsv
|
||||
|
||||
end submodule amg_z_base_onelev_setsv_impl
|
||||
|
||||
@@ -0,0 +1,333 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific prior written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 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.
|
||||
!
|
||||
!
|
||||
submodule (amg_z_onelev_mod) amg_z_base_onelev_wrk_handle_impl
|
||||
use psb_base_mod
|
||||
|
||||
contains
|
||||
|
||||
module subroutine z_base_onelev_move_alloc(lv, b,info)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
b%parms = lv%parms
|
||||
b%szratio = lv%szratio
|
||||
if (associated(lv%sm2,lv%sm2a)) then
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm2a
|
||||
else
|
||||
call move_alloc(lv%sm,b%sm)
|
||||
call move_alloc(lv%sm2a,b%sm2a)
|
||||
b%sm2 =>b%sm
|
||||
end if
|
||||
|
||||
call move_alloc(lv%aggr,b%aggr)
|
||||
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%linmap,b%linmap,info)
|
||||
if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info)
|
||||
b%base_a => lv%base_a
|
||||
b%base_desc => lv%base_desc
|
||||
|
||||
end subroutine z_base_onelev_move_alloc
|
||||
|
||||
module subroutine z_base_onelev_allocate_wrk(lv,info,vmold)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: nwv, i
|
||||
info = psb_success_
|
||||
nwv = lv%get_wrksz()
|
||||
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
|
||||
!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
|
||||
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
|
||||
|
||||
module subroutine z_base_onelev_free_wrk(lv,info)
|
||||
implicit none
|
||||
class(amg_z_onelev_type), target, intent(inout) :: lv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: nwv,i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(lv%wrk)) then
|
||||
call lv%wrk%free(info)
|
||||
if (info == 0) deallocate(lv%wrk,stat=info)
|
||||
end if
|
||||
end subroutine z_base_onelev_free_wrk
|
||||
|
||||
module subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2)
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
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)
|
||||
!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
|
||||
!!$ & present(desc2),desc%is_valid()
|
||||
|
||||
allocate(wk%wv(nwv),stat=info)
|
||||
if (present(desc2).and.(desc%is_valid())) then
|
||||
!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
|
||||
if (desc2%get_local_cols()>desc%get_local_cols()) then
|
||||
call z_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else
|
||||
call z_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
else if (present(desc2)) then
|
||||
call z_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
|
||||
else if (desc%is_valid()) then
|
||||
call z_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold)
|
||||
end if
|
||||
|
||||
contains
|
||||
end subroutine z_wrk_alloc
|
||||
|
||||
module subroutine z_inner_do_wrk_alloc(wk,nwv,desc,vmold)
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(in) :: nwv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
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)
|
||||
do i=1,nwv
|
||||
call psb_geasb(wk%wv(i),desc,info,&
|
||||
& scratch=.true.,mold=vmold)
|
||||
end do
|
||||
end subroutine z_inner_do_wrk_alloc
|
||||
|
||||
|
||||
module subroutine z_wrk_free(wk,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
|
||||
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
|
||||
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
|
||||
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
|
||||
call wk%vtx%free(info)
|
||||
call wk%vty%free(info)
|
||||
call wk%vx2l%free(info)
|
||||
call wk%vy2l%free(info)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%free(info)
|
||||
end do
|
||||
deallocate(wk%wv, stat=info)
|
||||
end if
|
||||
|
||||
end subroutine z_wrk_free
|
||||
|
||||
module subroutine z_wrk_clone(wk,wkout,info)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
info = psb_success_
|
||||
|
||||
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
|
||||
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
|
||||
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
|
||||
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
|
||||
call wk%vtx%clone(wkout%vtx,info)
|
||||
call wk%vty%clone(wkout%vty,info)
|
||||
call wk%vx2l%clone(wkout%vx2l,info)
|
||||
call wk%vy2l%clone(wkout%vy2l,info)
|
||||
if (allocated(wkout%wv)) then
|
||||
do i=1,size(wkout%wv)
|
||||
call wkout%wv(i)%free(info)
|
||||
end do
|
||||
deallocate( wkout%wv)
|
||||
end if
|
||||
allocate(wkout%wv(size(wk%wv)),stat=info)
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%clone(wkout%wv(i),info)
|
||||
end do
|
||||
return
|
||||
|
||||
end subroutine z_wrk_clone
|
||||
|
||||
module subroutine z_wrk_move_alloc(wk, b,info)
|
||||
implicit none
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
call b%free(info)
|
||||
call move_alloc(wk%tx,b%tx)
|
||||
call move_alloc(wk%ty,b%ty)
|
||||
call move_alloc(wk%x2l,b%x2l)
|
||||
call move_alloc(wk%y2l,b%y2l)
|
||||
!
|
||||
! Should define V%move_alloc....
|
||||
call move_alloc(wk%vtx%v,b%vtx%v)
|
||||
call move_alloc(wk%vty%v,b%vty%v)
|
||||
call move_alloc(wk%vx2l%v,b%vx2l%v)
|
||||
call move_alloc(wk%vy2l%v,b%vy2l%v)
|
||||
call move_alloc(wk%wv,b%wv)
|
||||
|
||||
end subroutine z_wrk_move_alloc
|
||||
|
||||
module subroutine z_wrk_cnv(wk,info,vmold)
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_zmlprec_wrk_type), target, intent(inout) :: wk
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
!
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
info = psb_success_
|
||||
if (present(vmold)) then
|
||||
call wk%vtx%cnv(vmold)
|
||||
call wk%vty%cnv(vmold)
|
||||
call wk%vx2l%cnv(vmold)
|
||||
call wk%vy2l%cnv(vmold)
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1,size(wk%wv)
|
||||
call wk%wv(i)%cnv(vmold)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
end subroutine z_wrk_cnv
|
||||
|
||||
module function z_wrk_sizeof(wk) result(val)
|
||||
implicit none
|
||||
class(amg_zmlprec_wrk_type), intent(in) :: wk
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
val = 0
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%tx)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%ty)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%x2l)
|
||||
val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%y2l)
|
||||
val = val + wk%vtx%sizeof()
|
||||
val = val + wk%vty%sizeof()
|
||||
val = val + wk%vx2l%sizeof()
|
||||
val = val + wk%vy2l%sizeof()
|
||||
if (allocated(wk%wv)) then
|
||||
do i=1, size(wk%wv)
|
||||
val = val + wk%wv(i)%sizeof()
|
||||
end do
|
||||
end if
|
||||
end function z_wrk_sizeof
|
||||
|
||||
module subroutine z_remap_data_clone(rmp, remap_out, info)
|
||||
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
|
||||
|
||||
module subroutine z_remap_move_alloc(rmp, remap_out, info)
|
||||
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 psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info)
|
||||
if (info == psb_success_) &
|
||||
& call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info)
|
||||
remap_out%idest = rmp%idest
|
||||
call move_alloc(rmp%isrc,remap_out%isrc)
|
||||
call move_alloc(rmp%nrsrc,remap_out%nrsrc)
|
||||
call move_alloc(rmp%naggr,remap_out%naggr)
|
||||
end subroutine z_remap_move_alloc
|
||||
|
||||
end submodule amg_z_base_onelev_wrk_handle_impl
|
||||
@@ -91,6 +91,10 @@ subroutine amg_c_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = cone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
@@ -172,6 +176,10 @@ subroutine amg_c_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = cone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -100,6 +100,10 @@ subroutine amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = cone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -103,6 +103,10 @@ subroutine amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = cone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -91,6 +91,10 @@ subroutine amg_d_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = done/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
@@ -172,6 +176,10 @@ subroutine amg_d_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = done/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -100,6 +100,10 @@ subroutine amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = done/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -103,6 +103,10 @@ subroutine amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = done/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -91,6 +91,10 @@ subroutine amg_s_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = sone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
@@ -172,6 +176,10 @@ subroutine amg_s_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = sone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -100,6 +100,10 @@ subroutine amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = sone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -103,6 +103,10 @@ subroutine amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = sone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -91,6 +91,10 @@ subroutine amg_z_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = zone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
@@ -172,6 +176,10 @@ subroutine amg_z_l1_diag_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = zone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -100,6 +100,10 @@ subroutine amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = zone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -103,6 +103,10 @@ subroutine amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
sv%d(i) = zone/sv%d(i)
|
||||
end if
|
||||
end do
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
allocate(sv%dv,stat=info)
|
||||
if (info == psb_success_) then
|
||||
call sv%dv%bld(sv%d)
|
||||
|
||||
@@ -3451,7 +3451,7 @@ fi
|
||||
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: Loaded $pac_cv_status_file $FC $MPIFC $BLACS_LIBS" >&5
|
||||
printf "%s\n" "$as_me: Loaded $pac_cv_status_file $FC $MPIFC $BLACS_LIBS" >&6;}
|
||||
am__api_version='1.17'
|
||||
am__api_version='1.18'
|
||||
|
||||
|
||||
|
||||
@@ -3721,10 +3721,14 @@ am_lf='
|
||||
'
|
||||
case `pwd` in
|
||||
*[\\\"\#\$\&\'\`$am_lf]*)
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
||||
printf "%s\n" "no" >&6; }
|
||||
as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;;
|
||||
esac
|
||||
case $srcdir in
|
||||
*[\\\"\#\$\&\'\`$am_lf\ \ ]*)
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
||||
printf "%s\n" "no" >&6; }
|
||||
as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;;
|
||||
esac
|
||||
|
||||
@@ -4189,9 +4193,133 @@ AMTAR='$${TAR-tar}'
|
||||
|
||||
|
||||
# We'll loop over all known methods to create a tar archive until one works.
|
||||
_am_tools='gnutar pax cpio none'
|
||||
_am_tools='gnutar plaintar pax cpio none'
|
||||
|
||||
am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'
|
||||
# The POSIX 1988 'ustar' format is defined with fixed-size fields.
|
||||
# There is notably a 21 bits limit for the UID and the GID. In fact,
|
||||
# the 'pax' utility can hang on bigger UID/GID (see automake bug#8343
|
||||
# and bug#13588).
|
||||
am_max_uid=2097151 # 2^21 - 1
|
||||
am_max_gid=$am_max_uid
|
||||
# The $UID and $GID variables are not portable, so we need to resort
|
||||
# to the POSIX-mandated id(1) utility. Errors in the 'id' calls
|
||||
# below are definitely unexpected, so allow the users to see them
|
||||
# (that is, avoid stderr redirection).
|
||||
am_uid=`id -u || echo unknown`
|
||||
am_gid=`id -g || echo unknown`
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether UID '$am_uid' is supported by ustar format" >&5
|
||||
printf %s "checking whether UID '$am_uid' is supported by ustar format... " >&6; }
|
||||
if test x$am_uid = xunknown; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ancient id detected; assuming current UID is ok, but dist-ustar might not work" >&5
|
||||
printf "%s\n" "$as_me: WARNING: ancient id detected; assuming current UID is ok, but dist-ustar might not work" >&2;}
|
||||
elif test $am_uid -le $am_max_uid; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
|
||||
printf "%s\n" "yes" >&6; }
|
||||
else
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
||||
printf "%s\n" "no" >&6; }
|
||||
_am_tools=none
|
||||
fi
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether GID '$am_gid' is supported by ustar format" >&5
|
||||
printf %s "checking whether GID '$am_gid' is supported by ustar format... " >&6; }
|
||||
if test x$gm_gid = xunknown; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: ancient id detected; assuming current GID is ok, but dist-ustar might not work" >&5
|
||||
printf "%s\n" "$as_me: WARNING: ancient id detected; assuming current GID is ok, but dist-ustar might not work" >&2;}
|
||||
elif test $am_gid -le $am_max_gid; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5
|
||||
printf "%s\n" "yes" >&6; }
|
||||
else
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
||||
printf "%s\n" "no" >&6; }
|
||||
_am_tools=none
|
||||
fi
|
||||
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to create a ustar tar archive" >&5
|
||||
printf %s "checking how to create a ustar tar archive... " >&6; }
|
||||
|
||||
# Go ahead even if we have the value already cached. We do so because we
|
||||
# need to set the values for the 'am__tar' and 'am__untar' variables.
|
||||
_am_tools=${am_cv_prog_tar_ustar-$_am_tools}
|
||||
|
||||
for _am_tool in $_am_tools; do
|
||||
case $_am_tool in
|
||||
gnutar)
|
||||
for _am_tar in tar gnutar gtar; do
|
||||
{ echo "$as_me:$LINENO: $_am_tar --version" >&5
|
||||
($_am_tar --version) >&5 2>&5
|
||||
ac_status=$?
|
||||
echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); } && break
|
||||
done
|
||||
am__tar="$_am_tar --format=ustar -chf - "'"$$tardir"'
|
||||
am__tar_="$_am_tar --format=ustar -chf - "'"$tardir"'
|
||||
am__untar="$_am_tar -xf -"
|
||||
;;
|
||||
plaintar)
|
||||
# Must skip GNU tar: if it does not support --format= it doesn't create
|
||||
# ustar tarball either.
|
||||
(tar --version) >/dev/null 2>&1 && continue
|
||||
am__tar='tar chf - "$$tardir"'
|
||||
am__tar_='tar chf - "$tardir"'
|
||||
am__untar='tar xf -'
|
||||
;;
|
||||
pax)
|
||||
am__tar='pax -L -x ustar -w "$$tardir"'
|
||||
am__tar_='pax -L -x ustar -w "$tardir"'
|
||||
am__untar='pax -r'
|
||||
;;
|
||||
cpio)
|
||||
am__tar='find "$$tardir" -print | cpio -o -H ustar -L'
|
||||
am__tar_='find "$tardir" -print | cpio -o -H ustar -L'
|
||||
am__untar='cpio -i -H ustar -d'
|
||||
;;
|
||||
none)
|
||||
am__tar=false
|
||||
am__tar_=false
|
||||
am__untar=false
|
||||
;;
|
||||
esac
|
||||
|
||||
# If the value was cached, stop now. We just wanted to have am__tar
|
||||
# and am__untar set.
|
||||
test -n "${am_cv_prog_tar_ustar}" && break
|
||||
|
||||
# tar/untar a dummy directory, and stop if the command works.
|
||||
rm -rf conftest.dir
|
||||
mkdir conftest.dir
|
||||
echo GrepMe > conftest.dir/file
|
||||
{ echo "$as_me:$LINENO: tardir=conftest.dir && eval $am__tar_ >conftest.tar" >&5
|
||||
(tardir=conftest.dir && eval $am__tar_ >conftest.tar) >&5 2>&5
|
||||
ac_status=$?
|
||||
echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); }
|
||||
rm -rf conftest.dir
|
||||
if test -s conftest.tar; then
|
||||
{ echo "$as_me:$LINENO: $am__untar <conftest.tar" >&5
|
||||
($am__untar <conftest.tar) >&5 2>&5
|
||||
ac_status=$?
|
||||
echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); }
|
||||
{ echo "$as_me:$LINENO: cat conftest.dir/file" >&5
|
||||
(cat conftest.dir/file) >&5 2>&5
|
||||
ac_status=$?
|
||||
echo "$as_me:$LINENO: \$? = $ac_status" >&5
|
||||
(exit $ac_status); }
|
||||
grep GrepMe conftest.dir/file >/dev/null 2>&1 && break
|
||||
fi
|
||||
done
|
||||
rm -rf conftest.dir
|
||||
|
||||
if test ${am_cv_prog_tar_ustar+y}
|
||||
then :
|
||||
printf %s "(cached) " >&6
|
||||
else case e in #(
|
||||
e) am_cv_prog_tar_ustar=$_am_tool ;;
|
||||
esac
|
||||
fi
|
||||
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_tar_ustar" >&5
|
||||
printf "%s\n" "$am_cv_prog_tar_ustar" >&6; }
|
||||
|
||||
|
||||
|
||||
@@ -5210,7 +5338,10 @@ _ACEOF
|
||||
break
|
||||
fi
|
||||
done
|
||||
rm -f core conftest*
|
||||
# aligned with autoconf, so not including core; see bug#72225.
|
||||
rm -f -r a.out a.exe b.out conftest.$ac_ext conftest.$ac_objext \
|
||||
conftest.dSYM conftest1.$ac_ext conftest1.$ac_objext conftest1.dSYM \
|
||||
conftest2.$ac_ext conftest2.$ac_objext conftest2.dSYM
|
||||
unset am_i ;;
|
||||
esac
|
||||
fi
|
||||
@@ -10651,6 +10782,12 @@ if test "x$amg4psblas_cv_have_mumps" == "xyes" ; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: PSBLAS defines PSB_LPK_ as $pac_cv_psblas_lpk. MUMPS interfacing will fail when called in global mode on very large matrices. " >&5
|
||||
printf "%s\n" "$as_me: PSBLAS defines PSB_LPK_ as $pac_cv_psblas_lpk. MUMPS interfacing will fail when called in global mode on very large matrices. " >&6;}
|
||||
fi
|
||||
MUMPS_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps -lmumps_common -lpord"
|
||||
if test "x$amg4psblas_cv_mumpslibdir" != "x" ; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: MUMPSLIBDIR $amg4psblas_cv_mumpslibdir .." >&5
|
||||
printf "%s\n" "$as_me: MUMPSLIBDIR $amg4psblas_cv_mumpslibdir .." >&6;}
|
||||
MUMPS_LIBS="${MUMPS_LIBS} -L$amg4psblas_cv_mumpslibdir"
|
||||
fi
|
||||
if test "x$pac_mumps_fmods_ok" == "xyes" ; then
|
||||
FDEFINES="$amg_cv_define_prepend-DAMG_HAVE_MUMPS $amg_cv_define_prepend-DAMG_HAVE_MUMPS_MODULES $MUMPS_MODULES $FDEFINES"
|
||||
MUMPS_FLAGS="-DAMG_HAVE_MUMPS $MUMPS_MODULES"
|
||||
|
||||
+5
-1
@@ -763,7 +763,11 @@ dnl fi
|
||||
if test "x$amg4psblas_cv_have_mumps" == "xyes" ; then
|
||||
if test "x$pac_cv_psblas_lpk" == "x8" ; then
|
||||
AC_MSG_NOTICE([PSBLAS defines PSB_LPK_ as $pac_cv_psblas_lpk. MUMPS interfacing will fail when called in global mode on very large matrices. ])
|
||||
fi
|
||||
fi
|
||||
MUMPS_LIBS="-lsmumps -ldmumps -lcmumps -lzmumps -lmumps_common -lpord"
|
||||
if test "x$amg4psblas_cv_mumpslibdir" != "x" ; then
|
||||
MUMPS_LIBS="${MUMPS_LIBS} -L$amg4psblas_cv_mumpslibdir"
|
||||
fi
|
||||
if test "x$pac_mumps_fmods_ok" == "xyes" ; then
|
||||
FDEFINES="$amg_cv_define_prepend-DAMG_HAVE_MUMPS $amg_cv_define_prepend-DAMG_HAVE_MUMPS_MODULES $MUMPS_MODULES $FDEFINES"
|
||||
MUMPS_FLAGS="-DAMG_HAVE_MUMPS $MUMPS_MODULES"
|
||||
|
||||
@@ -0,0 +1,72 @@
|
||||
AMGDIR=../../..
|
||||
AMGINCDIR=$(AMGDIR)/include
|
||||
include $(AMGINCDIR)/Make.inc.amg4psblas
|
||||
AMGMODDIR=$(AMGDIR)/modules
|
||||
AMGLIBDIR=$(AMGDIR)/lib
|
||||
AMG_LIBS=-L$(AMGLIBDIR) -lpsb_linsolve -lamg_prec -lpsb_prec -lpsb_ext
|
||||
FINCLUDES=$(FMFLAG). $(FMFLAG)$(AMGMODDIR) $(FMFLAG)$(AMGINCDIR) $(PSBLAS_INCLUDES) $(FIFLAG).
|
||||
|
||||
LINKOPT=
|
||||
EXEDIR=./runs
|
||||
|
||||
PSBMIXED=psb_mixed_support_mod.o
|
||||
|
||||
DGEN2D=amg_d_pde2d_poisson_mod.o amg_d_pde2d_exp_mod.o \
|
||||
amg_d_pde2d_gauss_mod.o amg_d_pde2d_box_mod.o
|
||||
DGEN3D=amg_d_pde3d_poisson_mod.o amg_d_pde3d_exp_mod.o \
|
||||
amg_d_pde3d_gauss_mod.o amg_d_pde3d_box_mod.o
|
||||
SGEN2D=amg_s_pde2d_poisson_mod.o amg_s_pde2d_exp_mod.o \
|
||||
amg_s_pde2d_gauss_mod.o amg_s_pde2d_box_mod.o
|
||||
SGEN3D=amg_s_pde3d_poisson_mod.o amg_s_pde3d_exp_mod.o \
|
||||
amg_s_pde3d_gauss_mod.o amg_s_pde3d_box_mod.o
|
||||
|
||||
all: dir amg_d_pde3d
|
||||
|
||||
dir:
|
||||
(if test ! -d $(EXEDIR); then mkdir $(EXEDIR); fi)
|
||||
|
||||
amg_d_pde3d: amg_d_pde3d.o amg_d_genpde_mod.o $(DGEN3D) $(PSBMIXED) data_input.o
|
||||
$(FLINK) $(LINKOPT) amg_d_pde3d.o amg_d_genpde_mod.o $(DGEN3D) $(PSBMIXED) data_input.o \
|
||||
-o amg_d_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(AMG_LDLIBS) $(LDLIBS)
|
||||
/bin/mv amg_d_pde3d $(EXEDIR)
|
||||
|
||||
amg_s_pde3d: amg_s_pde3d.o amg_s_genpde_mod.o $(SGEN3D) data_input.o
|
||||
$(FLINK) $(LINKOPT) amg_s_pde3d.o amg_s_genpde_mod.o $(SGEN3D) data_input.o \
|
||||
-o amg_s_pde3d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS)
|
||||
/bin/mv amg_s_pde3d $(EXEDIR)
|
||||
|
||||
amg_d_pde2d: amg_d_pde2d.o amg_d_genpde_mod.o $(DGEN2D) data_input.o
|
||||
$(FLINK) $(LINKOPT) amg_d_pde2d.o amg_d_genpde_mod.o $(DGEN2D) data_input.o \
|
||||
-o amg_d_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS)
|
||||
/bin/mv amg_d_pde2d $(EXEDIR)
|
||||
|
||||
amg_s_pde2d: amg_s_pde2d.o amg_s_genpde_mod.o $(SGEN2D) data_input.o
|
||||
$(FLINK) $(LINKOPT) amg_s_pde2d.o amg_s_genpde_mod.o $(SGEN2D) data_input.o \
|
||||
-o amg_s_pde2d $(AMG_LIBS) $(PSBLAS_LIBS) $(LDLIBS)
|
||||
/bin/mv amg_s_pde2d $(EXEDIR)
|
||||
|
||||
|
||||
amg_d_pde3d.o amg_s_pde3d.o amg_d_pde2d.o amg_s_pde2d.o: data_input.o
|
||||
|
||||
amg_d_pde3d.o: amg_d_genpde_mod.o $(DGEN3D) $(PSBMIXED)
|
||||
amg_s_pde3d.o: amg_s_genpde_mod.o $(SGEN3D)
|
||||
amg_d_pde2d.o: amg_d_genpde_mod.o $(DGEN2D)
|
||||
amg_s_pde2d.o: amg_s_genpde_mod.o $(SGEN2D)
|
||||
|
||||
amg_d_genpde_mod.o: $(DGEN3D)
|
||||
amg_s_genpde_mod.o: $(SGEN3D)
|
||||
amg_d_genpde_mod.o: $(DGEN2D)
|
||||
amg_s_genpde_mod.o: $(SGEN2D)
|
||||
|
||||
check: all
|
||||
cd runs && ./amg_d_pde2d <amg_pde2d.inp && ./amg_s_pde2d<amg_pde2d.inp
|
||||
|
||||
|
||||
clean:
|
||||
/bin/rm -f data_input.o *.o *$(.mod)\
|
||||
$(EXEDIR)/amg_d_pde3d $(EXEDIR)/amg_s_pde3d $(EXEDIR)/amg_d_pde2d $(EXEDIR)/amg_s_pde2d
|
||||
|
||||
verycleanlib:
|
||||
(cd ../..; make veryclean)
|
||||
lib:
|
||||
(cd ../../; make library)
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user