mirror of
https://github.com/sfilippone/amg4psblas.git
synced 2026-10-07 07:04:59 +00:00
Compare commits
44
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 Salvatore Filippone
|
be4e7b4837 | ||
|
Salvatore Filippone
|
83c14397eb | ||
|
Salvatore Filippone
|
f67b61d23f | ||
|
Salvatore Filippone
|
a72690f9c3 | ||
|
Salvatore Filippone
|
5c2eef76ab | ||
|
Salvatore Filippone
|
ce0850f6fc | ||
|
Salvatore Filippone
|
c9e1719098 | ||
|
Salvatore Filippone
|
8f73ddfbce | ||
|
Salvatore Filippone
|
f496d4856b | ||
|
Salvatore Filippone
|
49259c79b3 | ||
|
Salvatore Filippone
|
2894a0944b | ||
|
Salvatore Filippone
|
9c95835ed5 | ||
|
Salvatore Filippone
|
6259514cd1 | ||
|
Salvatore Filippone
|
7fe0eb8580 | ||
 Cirdans-Home
|
d249042ea2 | ||
|
Salvatore Filippone
|
adc5aebd6b | ||
|
Salvatore Filippone
|
108b4dd00d | ||
|
Salvatore Filippone
|
d2264f5f11 | ||
|
Salvatore Filippone
|
8e2af97a35 | ||
|
Salvatore Filippone
|
4260dc74d5 | ||
|
Salvatore Filippone
|
940609564f | ||
|
Salvatore Filippone
|
d81bb30844 | ||
|
Salvatore Filippone
|
95d3c06e17 | ||
|
Salvatore Filippone
|
b57967be6e | ||
|
Salvatore Filippone
|
3dd15cc007 | ||
|
Salvatore Filippone
|
d55dd1f21b | ||
|
Salvatore Filippone
|
9ba74e89cd | ||
|
Salvatore Filippone
|
07a2a97b13 | ||
|
Salvatore Filippone
|
dad39223ec | ||
|
Salvatore Filippone
|
94a412e92a | ||
|
Salvatore Filippone
|
8b0577069f | ||
|
Salvatore Filippone
|
a83ccc7f52 | ||
|
Salvatore Filippone
|
32d550ed05 | ||
|
Salvatore Filippone
|
f7059c285d | ||
|
Salvatore Filippone
|
5b9f76354b | ||
|
Salvatore Filippone
|
4d1a87e5d8 | ||
|
Cirdans-Home
|
8eae0dc459 | ||
|
Salvatore Filippone
|
8f60a49fc6 | ||
|
Salvatore Filippone
|
de75eec402 | ||
|
Salvatore Filippone
|
8f167a3295 | ||
|
Salvatore Filippone
|
0854eee936 | ||
|
Salvatore Filippone
|
441c607c4a | ||
|
Salvatore Filippone
|
6ac8cffa0a | ||
|
Salvatore Filippone
|
c0b033da57 |
@@ -8,7 +8,7 @@ module mld_dprec_cbind_mod
|
||||
type(c_ptr) :: item = c_null_ptr
|
||||
end type mld_c_dprec
|
||||
|
||||
contains
|
||||
contains
|
||||
|
||||
#if 1
|
||||
#define MLDC_DEBUG(MSG) write(*,*) __FILE__,':',__LINE__,':',MSG
|
||||
@@ -21,13 +21,13 @@ contains
|
||||
!#define MLDC_ERR_FILTER(INFO) min(0,INFO)
|
||||
#define MLDC_ERR_FILTER(INFO) (INFO)
|
||||
#define MLDC_ERR_HANDLE(INFO) if(INFO/=mld_success_)MLDC_ERROR("ERROR!")
|
||||
|
||||
|
||||
function mld_c_dprecinit(ictxt,ph,ptype) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(mld_c_dprec) :: ph
|
||||
integer(psb_c_ipk_), value :: ictxt
|
||||
character(c_char) :: ptype(*)
|
||||
@@ -36,20 +36,20 @@ contains
|
||||
character(len=80) :: fptype
|
||||
|
||||
res = -1
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
return
|
||||
if (c_associated(ph%item)) then
|
||||
res = 0
|
||||
return
|
||||
end if
|
||||
|
||||
allocate(precp,stat=info)
|
||||
if (info /= 0) return
|
||||
|
||||
|
||||
ph%item = c_loc(precp)
|
||||
|
||||
call stringc2f(ptype,fptype)
|
||||
|
||||
call precp%init(ictxt,fptype,info)
|
||||
|
||||
|
||||
call precp%init(ictxt,fptype,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
@@ -58,9 +58,9 @@ contains
|
||||
function mld_c_dprecseti(ph,what,val) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
character(c_char) :: what(*)
|
||||
integer(psb_c_ipk_), value :: val
|
||||
@@ -69,28 +69,28 @@ contains
|
||||
type(mld_dprec_type), pointer :: precp
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call stringc2f(what,fwhat)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
end function mld_c_dprecseti
|
||||
|
||||
|
||||
|
||||
function mld_c_dprecsetr(ph,what,val) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
character(c_char) :: what(*)
|
||||
real(c_double), value :: val
|
||||
@@ -99,27 +99,27 @@ contains
|
||||
type(mld_dprec_type), pointer :: precp
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call stringc2f(what,fwhat)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
end function mld_c_dprecsetr
|
||||
|
||||
|
||||
function mld_c_dprecsetc(ph,what,val) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
character(c_char) :: what(*), val(*)
|
||||
integer :: info
|
||||
@@ -127,17 +127,17 @@ contains
|
||||
type(mld_dprec_type), pointer :: precp
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call stringc2f(what,fwhat)
|
||||
call stringc2f(val,fval)
|
||||
|
||||
call mld_precset(precp,fwhat,fval,info)
|
||||
|
||||
call mld_precset(precp,fwhat,fval,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
@@ -146,9 +146,9 @@ contains
|
||||
function mld_c_dprecbld(ah,cdh,ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph,ah,cdh
|
||||
integer :: info
|
||||
type(mld_dprec_type), pointer :: precp
|
||||
@@ -158,36 +158,36 @@ contains
|
||||
|
||||
res = -1
|
||||
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call mld_precbld(ap,descp,precp,info)
|
||||
call mld_precbld(ap,descp,precp,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
|
||||
return
|
||||
end function mld_c_dprecbld
|
||||
|
||||
|
||||
function mld_c_dhierarchy_build(ah,cdh,ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph,ah,cdh
|
||||
integer :: info
|
||||
type(mld_dprec_type), pointer :: precp
|
||||
@@ -197,23 +197,23 @@ contains
|
||||
|
||||
res = -1
|
||||
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call precp%hierarchy_build(ap,descp,info)
|
||||
call precp%hierarchy_build(ap,descp,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
@@ -224,9 +224,9 @@ contains
|
||||
function mld_c_dsmoothers_build(ah,cdh,ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph,ah,cdh
|
||||
integer :: info
|
||||
type(mld_dprec_type), pointer :: precp
|
||||
@@ -236,30 +236,30 @@ contains
|
||||
|
||||
res = -1
|
||||
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call precp%smoothers_build(ap,descp,info)
|
||||
call precp%smoothers_build(ap,descp,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
|
||||
return
|
||||
end function mld_c_dsmoothers_build
|
||||
|
||||
|
||||
function mld_c_dkrylov(methd,&
|
||||
& ah,ph,bh,xh,cdh,options) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
@@ -267,17 +267,17 @@ contains
|
||||
use psb_krylov_mod
|
||||
use psb_prec_cbind_mod
|
||||
use psb_dkrylov_cbind_mod
|
||||
implicit none
|
||||
implicit none
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
|
||||
character(c_char) :: methd(*)
|
||||
type(solveroptions) :: options
|
||||
|
||||
|
||||
res= mld_c_dkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
|
||||
& itmax=options%itmax, iter=options%iter,&
|
||||
& itrace=options%itrace, istop=options%istop,&
|
||||
& irst=options%irst, err=options%err)
|
||||
|
||||
|
||||
end function mld_c_dkrylov
|
||||
|
||||
|
||||
@@ -289,7 +289,7 @@ contains
|
||||
use psb_objhandle_mod
|
||||
use psb_prec_cbind_mod
|
||||
use psb_base_string_cbind_mod
|
||||
implicit none
|
||||
implicit none
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
|
||||
integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
|
||||
@@ -307,33 +307,33 @@ contains
|
||||
real(kind(1.d0)) :: feps,ferr
|
||||
|
||||
res = -1
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(xh%item)) then
|
||||
if (c_associated(xh%item)) then
|
||||
call c_f_pointer(xh%item,xp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(bh%item)) then
|
||||
if (c_associated(bh%item)) then
|
||||
call c_f_pointer(bh%item,bp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
|
||||
call stringc2f(methd,fmethd)
|
||||
feps = eps
|
||||
fitmax = itmax
|
||||
@@ -348,34 +348,33 @@ contains
|
||||
iter = fiter
|
||||
err = ferr
|
||||
res = min(info,0)
|
||||
|
||||
|
||||
end function mld_c_dkrylov_opt
|
||||
|
||||
function mld_c_dprecfree(ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
integer :: info
|
||||
type(mld_dprec_type), pointer :: precp
|
||||
character(len=80) :: fptype
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
call precp%free(info)
|
||||
|
||||
|
||||
call precp%free(info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
end function mld_c_dprecfree
|
||||
|
||||
end module mld_dprec_cbind_mod
|
||||
|
||||
|
||||
@@ -8,7 +8,7 @@ module mld_zprec_cbind_mod
|
||||
type(c_ptr) :: item = c_null_ptr
|
||||
end type mld_c_zprec
|
||||
|
||||
contains
|
||||
contains
|
||||
|
||||
#if 1
|
||||
#define MLDC_DEBUG(MSG) write(*,*) __FILE__,':',__LINE__,':',MSG
|
||||
@@ -21,13 +21,13 @@ contains
|
||||
!#define MLDC_ERR_FILTER(INFO) min(0,INFO)
|
||||
#define MLDC_ERR_FILTER(INFO) (INFO)
|
||||
#define MLDC_ERR_HANDLE(INFO) if(INFO/=mld_success_)MLDC_ERROR("ERROR!")
|
||||
|
||||
|
||||
function mld_c_zprecinit(ictxt,ph,ptype) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(mld_c_zprec) :: ph
|
||||
integer(psb_c_ipk_), value :: ictxt
|
||||
character(c_char) :: ptype(*)
|
||||
@@ -36,20 +36,20 @@ contains
|
||||
character(len=80) :: fptype
|
||||
|
||||
res = -1
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
return
|
||||
if (c_associated(ph%item)) then
|
||||
res = 0
|
||||
return
|
||||
end if
|
||||
|
||||
allocate(precp,stat=info)
|
||||
if (info /= 0) return
|
||||
|
||||
|
||||
ph%item = c_loc(precp)
|
||||
|
||||
call stringc2f(ptype,fptype)
|
||||
|
||||
call precp%init(ictxt,fptype,info)
|
||||
|
||||
|
||||
call precp%init(ictxt,fptype,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
@@ -58,9 +58,9 @@ contains
|
||||
function mld_c_zprecseti(ph,what,val) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
character(c_char) :: what(*)
|
||||
integer(psb_c_ipk_), value :: val
|
||||
@@ -69,28 +69,28 @@ contains
|
||||
type(mld_zprec_type), pointer :: precp
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call stringc2f(what,fwhat)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
end function mld_c_zprecseti
|
||||
|
||||
|
||||
|
||||
function mld_c_zprecsetr(ph,what,val) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
character(c_char) :: what(*)
|
||||
real(c_double), value :: val
|
||||
@@ -99,27 +99,27 @@ contains
|
||||
type(mld_zprec_type), pointer :: precp
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call stringc2f(what,fwhat)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
call mld_precset(precp,fwhat,val,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
end function mld_c_zprecsetr
|
||||
|
||||
|
||||
function mld_c_zprecsetc(ph,what,val) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
character(c_char) :: what(*), val(*)
|
||||
integer :: info
|
||||
@@ -127,17 +127,17 @@ contains
|
||||
type(mld_zprec_type), pointer :: precp
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call stringc2f(what,fwhat)
|
||||
call stringc2f(val,fval)
|
||||
|
||||
call mld_precset(precp,fwhat,fval,info)
|
||||
|
||||
call mld_precset(precp,fwhat,fval,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
@@ -146,9 +146,9 @@ contains
|
||||
function mld_c_zprecbld(ah,cdh,ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph,ah,cdh
|
||||
integer :: info
|
||||
type(mld_zprec_type), pointer :: precp
|
||||
@@ -158,36 +158,36 @@ contains
|
||||
|
||||
res = -1
|
||||
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call mld_precbld(ap,descp,precp,info)
|
||||
call mld_precbld(ap,descp,precp,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
|
||||
return
|
||||
end function mld_c_zprecbld
|
||||
|
||||
|
||||
function mld_c_zhierarchy_build(ah,cdh,ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph,ah,cdh
|
||||
integer :: info
|
||||
type(mld_zprec_type), pointer :: precp
|
||||
@@ -197,23 +197,23 @@ contains
|
||||
|
||||
res = -1
|
||||
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call precp%hierarchy_build(ap,descp,info)
|
||||
call precp%hierarchy_build(ap,descp,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
@@ -224,9 +224,9 @@ contains
|
||||
function mld_c_zsmoothers_build(ah,cdh,ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph,ah,cdh
|
||||
integer :: info
|
||||
type(mld_zprec_type), pointer :: precp
|
||||
@@ -236,30 +236,30 @@ contains
|
||||
|
||||
res = -1
|
||||
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
call precp%smoothers_build(ap,descp,info)
|
||||
call precp%smoothers_build(ap,descp,info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
|
||||
return
|
||||
end function mld_c_zsmoothers_build
|
||||
|
||||
|
||||
function mld_c_zkrylov(methd,&
|
||||
& ah,ph,bh,xh,cdh,options) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
@@ -267,17 +267,17 @@ contains
|
||||
use psb_krylov_mod
|
||||
use psb_prec_cbind_mod
|
||||
use psb_zkrylov_cbind_mod
|
||||
implicit none
|
||||
implicit none
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
|
||||
character(c_char) :: methd(*)
|
||||
type(solveroptions) :: options
|
||||
|
||||
|
||||
res= mld_c_zkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
|
||||
& itmax=options%itmax, iter=options%iter,&
|
||||
& itrace=options%itrace, istop=options%istop,&
|
||||
& irst=options%irst, err=options%err)
|
||||
|
||||
|
||||
end function mld_c_zkrylov
|
||||
|
||||
|
||||
@@ -289,7 +289,7 @@ contains
|
||||
use psb_objhandle_mod
|
||||
use psb_prec_cbind_mod
|
||||
use psb_base_string_cbind_mod
|
||||
implicit none
|
||||
implicit none
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
|
||||
integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
|
||||
@@ -307,33 +307,33 @@ contains
|
||||
real(kind(1.d0)) :: feps,ferr
|
||||
|
||||
res = -1
|
||||
if (c_associated(cdh%item)) then
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(xh%item)) then
|
||||
if (c_associated(xh%item)) then
|
||||
call c_f_pointer(xh%item,xp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(bh%item)) then
|
||||
if (c_associated(bh%item)) then
|
||||
call c_f_pointer(bh%item,bp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
|
||||
call stringc2f(methd,fmethd)
|
||||
feps = eps
|
||||
fitmax = itmax
|
||||
@@ -348,34 +348,33 @@ contains
|
||||
iter = fiter
|
||||
err = ferr
|
||||
res = min(info,0)
|
||||
|
||||
|
||||
end function mld_c_zkrylov_opt
|
||||
|
||||
function mld_c_zprecfree(ph) bind(c) result(res)
|
||||
use psb_base_mod
|
||||
use mld_prec_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
implicit none
|
||||
|
||||
integer(psb_c_ipk_) :: res
|
||||
type(psb_c_object_type) :: ph
|
||||
integer :: info
|
||||
type(mld_zprec_type), pointer :: precp
|
||||
character(len=80) :: fptype
|
||||
|
||||
res = -1
|
||||
if (c_associated(ph%item)) then
|
||||
if (c_associated(ph%item)) then
|
||||
call c_f_pointer(ph%item,precp)
|
||||
else
|
||||
return
|
||||
return
|
||||
end if
|
||||
|
||||
|
||||
call precp%free(info)
|
||||
|
||||
|
||||
call precp%free(info)
|
||||
|
||||
res = MLDC_ERR_FILTER(info)
|
||||
MLDC_ERR_HANDLE(res)
|
||||
return
|
||||
end function mld_c_zprecfree
|
||||
|
||||
end module mld_zprec_cbind_mod
|
||||
|
||||
|
||||
@@ -69,15 +69,16 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold
|
||||
type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold
|
||||
type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold
|
||||
type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold
|
||||
type(mld_c_l1_diag_solver_type) :: mld_c_l1_diag_solver_mold
|
||||
type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold
|
||||
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
|
||||
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
|
||||
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
|
||||
type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold
|
||||
type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold
|
||||
type(mld_c_l1_jac_smoother_type) :: mld_c_l1_jac_smoother_mold
|
||||
type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold
|
||||
type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold
|
||||
type(mld_c_l1_diag_solver_type) :: mld_c_l1_diag_solver_mold
|
||||
type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold
|
||||
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
|
||||
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
|
||||
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
|
||||
#if defined(HAVE_SLU_)
|
||||
type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold
|
||||
#endif
|
||||
@@ -124,16 +125,41 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('BJAC')
|
||||
call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(mld_c_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(mld_c_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FWGS')
|
||||
call lv%set(mld_c_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(mld_c_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('FBGS')
|
||||
call lv%set(mld_c_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_c_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
call lv%set(mld_c_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(mld_c_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(mld_c_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_c_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_c_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_c_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
case default
|
||||
!
|
||||
|
||||
@@ -68,15 +68,16 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='c_base_onelev_cseti'
|
||||
type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold
|
||||
type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold
|
||||
type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold
|
||||
type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold
|
||||
type(mld_c_l1_diag_solver_type) :: mld_c_l1_diag_solver_mold
|
||||
type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold
|
||||
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
|
||||
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
|
||||
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
|
||||
type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold
|
||||
type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold
|
||||
type(mld_c_l1_jac_smoother_type) :: mld_c_l1_jac_smoother_mold
|
||||
type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold
|
||||
type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold
|
||||
type(mld_c_l1_diag_solver_type) :: mld_c_l1_diag_solver_mold
|
||||
type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold
|
||||
type(mld_c_id_solver_type) :: mld_c_id_solver_mold
|
||||
type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold
|
||||
type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold
|
||||
#if defined(HAVE_SLU_)
|
||||
type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold
|
||||
#endif
|
||||
@@ -118,6 +119,10 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
case (mld_bjac_)
|
||||
call lv%set(mld_c_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_l1_bjac_)
|
||||
call lv%set(mld_c_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_as_)
|
||||
call lv%set(mld_c_as_smoother_mold,info,pos=pos)
|
||||
|
||||
@@ -146,13 +146,24 @@ subroutine mld_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm")
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a")
|
||||
if (level >= 2) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%desc_ac,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%desc_ac,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
else
|
||||
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 mld_c_base_onelev_dump
|
||||
|
||||
@@ -75,15 +75,16 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold
|
||||
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
|
||||
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
|
||||
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
|
||||
type(mld_d_l1_diag_solver_type) :: mld_d_l1_diag_solver_mold
|
||||
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
|
||||
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
|
||||
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
|
||||
type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold
|
||||
type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold
|
||||
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
|
||||
type(mld_d_l1_jac_smoother_type) :: mld_d_l1_jac_smoother_mold
|
||||
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
|
||||
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
|
||||
type(mld_d_l1_diag_solver_type) :: mld_d_l1_diag_solver_mold
|
||||
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
|
||||
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
|
||||
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
|
||||
type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold
|
||||
#if defined(HAVE_UMF_)
|
||||
type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold
|
||||
#endif
|
||||
@@ -136,16 +137,41 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('BJAC')
|
||||
call lv%set(mld_d_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(mld_d_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(mld_d_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FWGS')
|
||||
call lv%set(mld_d_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(mld_d_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('FBGS')
|
||||
call lv%set(mld_d_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_d_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
call lv%set(mld_d_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(mld_d_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(mld_d_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_d_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_d_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_d_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
case default
|
||||
!
|
||||
|
||||
@@ -74,15 +74,16 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='d_base_onelev_cseti'
|
||||
type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold
|
||||
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
|
||||
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
|
||||
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
|
||||
type(mld_d_l1_diag_solver_type) :: mld_d_l1_diag_solver_mold
|
||||
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
|
||||
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
|
||||
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
|
||||
type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold
|
||||
type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold
|
||||
type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold
|
||||
type(mld_d_l1_jac_smoother_type) :: mld_d_l1_jac_smoother_mold
|
||||
type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold
|
||||
type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold
|
||||
type(mld_d_l1_diag_solver_type) :: mld_d_l1_diag_solver_mold
|
||||
type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold
|
||||
type(mld_d_id_solver_type) :: mld_d_id_solver_mold
|
||||
type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold
|
||||
type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold
|
||||
#if defined(HAVE_UMF_)
|
||||
type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold
|
||||
#endif
|
||||
@@ -130,6 +131,10 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
case (mld_bjac_)
|
||||
call lv%set(mld_d_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_l1_bjac_)
|
||||
call lv%set(mld_d_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_as_)
|
||||
call lv%set(mld_d_as_smoother_mold,info,pos=pos)
|
||||
|
||||
@@ -146,13 +146,24 @@ subroutine mld_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm")
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a")
|
||||
if (level >= 2) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%desc_ac,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%desc_ac,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
else
|
||||
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 mld_d_base_onelev_dump
|
||||
|
||||
@@ -69,15 +69,16 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold
|
||||
type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold
|
||||
type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold
|
||||
type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold
|
||||
type(mld_s_l1_diag_solver_type) :: mld_s_l1_diag_solver_mold
|
||||
type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold
|
||||
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
|
||||
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
|
||||
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
|
||||
type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold
|
||||
type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold
|
||||
type(mld_s_l1_jac_smoother_type) :: mld_s_l1_jac_smoother_mold
|
||||
type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold
|
||||
type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold
|
||||
type(mld_s_l1_diag_solver_type) :: mld_s_l1_diag_solver_mold
|
||||
type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold
|
||||
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
|
||||
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
|
||||
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
|
||||
#if defined(HAVE_SLU_)
|
||||
type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold
|
||||
#endif
|
||||
@@ -124,16 +125,41 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('BJAC')
|
||||
call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(mld_s_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(mld_s_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FWGS')
|
||||
call lv%set(mld_s_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(mld_s_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('FBGS')
|
||||
call lv%set(mld_s_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_s_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
call lv%set(mld_s_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(mld_s_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(mld_s_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_s_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_s_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_s_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
case default
|
||||
!
|
||||
|
||||
@@ -68,15 +68,16 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='s_base_onelev_cseti'
|
||||
type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold
|
||||
type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold
|
||||
type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold
|
||||
type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold
|
||||
type(mld_s_l1_diag_solver_type) :: mld_s_l1_diag_solver_mold
|
||||
type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold
|
||||
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
|
||||
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
|
||||
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
|
||||
type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold
|
||||
type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold
|
||||
type(mld_s_l1_jac_smoother_type) :: mld_s_l1_jac_smoother_mold
|
||||
type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold
|
||||
type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold
|
||||
type(mld_s_l1_diag_solver_type) :: mld_s_l1_diag_solver_mold
|
||||
type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold
|
||||
type(mld_s_id_solver_type) :: mld_s_id_solver_mold
|
||||
type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold
|
||||
type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold
|
||||
#if defined(HAVE_SLU_)
|
||||
type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold
|
||||
#endif
|
||||
@@ -118,6 +119,10 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
case (mld_bjac_)
|
||||
call lv%set(mld_s_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_l1_bjac_)
|
||||
call lv%set(mld_s_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_as_)
|
||||
call lv%set(mld_s_as_smoother_mold,info,pos=pos)
|
||||
|
||||
@@ -146,13 +146,24 @@ subroutine mld_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm")
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a")
|
||||
if (level >= 2) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%desc_ac,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%desc_ac,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
else
|
||||
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 mld_s_base_onelev_dump
|
||||
|
||||
@@ -75,15 +75,16 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_csetc'
|
||||
integer(psb_ipk_) :: ival
|
||||
type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold
|
||||
type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold
|
||||
type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold
|
||||
type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold
|
||||
type(mld_z_l1_diag_solver_type) :: mld_z_l1_diag_solver_mold
|
||||
type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold
|
||||
type(mld_z_id_solver_type) :: mld_z_id_solver_mold
|
||||
type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold
|
||||
type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold
|
||||
type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold
|
||||
type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold
|
||||
type(mld_z_l1_jac_smoother_type) :: mld_z_l1_jac_smoother_mold
|
||||
type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold
|
||||
type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold
|
||||
type(mld_z_l1_diag_solver_type) :: mld_z_l1_diag_solver_mold
|
||||
type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold
|
||||
type(mld_z_id_solver_type) :: mld_z_id_solver_mold
|
||||
type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold
|
||||
type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold
|
||||
#if defined(HAVE_UMF_)
|
||||
type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold
|
||||
#endif
|
||||
@@ -136,16 +137,41 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('BJAC')
|
||||
call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-BJAC')
|
||||
call lv%set(mld_z_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('AS')
|
||||
call lv%set(mld_z_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FWGS')
|
||||
call lv%set(mld_z_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('BWGS')
|
||||
call lv%set(mld_z_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('FBGS')
|
||||
call lv%set(mld_z_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_z_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='post')
|
||||
case ('L1-GS','L1-FWGS')
|
||||
call lv%set(mld_z_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-BWGS')
|
||||
call lv%set(mld_z_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='pre')
|
||||
if (allocated(lv%sm2a)) deallocate(lv%sm2a)
|
||||
case ('L1-FBGS')
|
||||
call lv%set(mld_z_l1_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(mld_z_gs_solver_mold,info,pos='pre')
|
||||
call lv%set(mld_z_l1_jac_smoother_mold,info,pos='post')
|
||||
if (info == 0) call lv%set(mld_z_bwgs_solver_mold,info,pos='post')
|
||||
|
||||
case default
|
||||
!
|
||||
|
||||
@@ -74,15 +74,16 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
! Local
|
||||
integer(psb_ipk_) :: ipos_, err_act
|
||||
character(len=20) :: name='z_base_onelev_cseti'
|
||||
type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold
|
||||
type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold
|
||||
type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold
|
||||
type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold
|
||||
type(mld_z_l1_diag_solver_type) :: mld_z_l1_diag_solver_mold
|
||||
type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold
|
||||
type(mld_z_id_solver_type) :: mld_z_id_solver_mold
|
||||
type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold
|
||||
type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold
|
||||
type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold
|
||||
type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold
|
||||
type(mld_z_l1_jac_smoother_type) :: mld_z_l1_jac_smoother_mold
|
||||
type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold
|
||||
type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold
|
||||
type(mld_z_l1_diag_solver_type) :: mld_z_l1_diag_solver_mold
|
||||
type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold
|
||||
type(mld_z_id_solver_type) :: mld_z_id_solver_mold
|
||||
type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold
|
||||
type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold
|
||||
#if defined(HAVE_UMF_)
|
||||
type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold
|
||||
#endif
|
||||
@@ -130,6 +131,10 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
case (mld_bjac_)
|
||||
call lv%set(mld_z_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_l1_bjac_)
|
||||
call lv%set(mld_z_l1_jac_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case (mld_as_)
|
||||
call lv%set(mld_z_as_smoother_mold,info,pos=pos)
|
||||
|
||||
@@ -146,13 +146,24 @@ subroutine mld_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,&
|
||||
end if
|
||||
end if
|
||||
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm")
|
||||
end if
|
||||
if (allocated(lv%sm2a)) then
|
||||
call lv%sm2a%dump(icontxt,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a")
|
||||
if (level >= 2) then
|
||||
if (allocated(lv%sm)) then
|
||||
call lv%sm%dump(lv%desc_ac,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%desc_ac,level,info,smoother=smoother, &
|
||||
& solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num)
|
||||
end if
|
||||
else
|
||||
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 mld_z_base_onelev_dump
|
||||
|
||||
@@ -273,10 +273,12 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
|
||||
!
|
||||
! Finest level first; remember to fix base_a and base_desc
|
||||
! Finest level first; create a GEN_BLOCK
|
||||
! copy of the descriptor.
|
||||
!
|
||||
prec%precv(1)%base_a => a
|
||||
prec%precv(1)%base_desc => desc_a
|
||||
call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
newsz = 0
|
||||
array_build_loop: do i=2, iszv
|
||||
!
|
||||
@@ -317,7 +319,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Return from ',i,' call to mlprcbld ',info
|
||||
& 'Return from ',i,' call to bld_tprol', info
|
||||
!
|
||||
! Save op_prol just in case
|
||||
!
|
||||
@@ -334,9 +336,9 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
if (iaggsize <= casize) then
|
||||
newsz = i
|
||||
end if
|
||||
|
||||
if (iaggsize <= casize) newsz = i
|
||||
if (i == iszv) newsz = i
|
||||
|
||||
if (i>2) then
|
||||
if (sizeratio < mnaggratio) then
|
||||
@@ -440,7 +442,10 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
! Restart
|
||||
iszv = newsz
|
||||
! Fix the pointers, but the level 1 should
|
||||
! be already OK
|
||||
! be treated differently
|
||||
if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
end if
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
@@ -449,11 +454,6 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
! Does the coarsening need backfix on descriptors?
|
||||
do i=2, iszv
|
||||
if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
@@ -478,7 +478,7 @@ subroutine mld_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
contains
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(mld_c_onelev_type), intent(in) :: level
|
||||
type(mld_c_onelev_type), intent(inout) :: level
|
||||
class(mld_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
@@ -493,15 +493,19 @@ contains
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
|
||||
|
||||
allocate(save1, mold=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, mold=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(mld_c_onelev_type), intent(inout), target :: level
|
||||
class(mld_c_base_smoother_type), allocatable, intent(in) :: save1, save2
|
||||
class(mld_c_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
@@ -511,7 +515,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) allocate(level%sm,mold=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
@@ -521,7 +526,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) allocate(level%sm2a,mold=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
|
||||
@@ -256,7 +256,7 @@ subroutine mld_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but the coarse matrix has been changed to replicated'
|
||||
end if
|
||||
|
||||
case(mld_bjac_,mld_jac_, mld_l1_jac_)
|
||||
case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
|
||||
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'MLD2P4: Warning: original coarse solver was requested as ',&
|
||||
|
||||
+153
-106
@@ -188,75 +188,75 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_umf_)
|
||||
case(mld_umf_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
|
||||
case(mld_sludist_)
|
||||
case(mld_sludist_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_jac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
@@ -267,6 +267,18 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -325,8 +337,8 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
@@ -401,6 +413,18 @@ subroutine mld_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
@@ -569,75 +593,75 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('UMF')
|
||||
case('UMF')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
|
||||
case('SLUDIST')
|
||||
case('SLUDIST')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('JAC','JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
@@ -648,6 +672,18 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -687,9 +723,9 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
case('COARSE_SOLVE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (string)
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
@@ -759,11 +795,22 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
|
||||
case('L1-JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
|
||||
@@ -50,10 +50,15 @@
|
||||
!
|
||||
! 'DIAG', 'JACOBI' - diagonal/Jacobi
|
||||
!
|
||||
! 'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi with L1 norm correction
|
||||
!
|
||||
! 'GS', 'FBGS' - Hybrid Gauss-Seidel, also symmetrized
|
||||
!
|
||||
! 'BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks
|
||||
!
|
||||
! 'L1-BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks and L1 correction for off-diag blocks
|
||||
!
|
||||
! 'AS' - Additive Schwarz (AS), with
|
||||
! overlap 1 and ILU(0) on the local submatrices
|
||||
@@ -121,7 +126,7 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
|
||||
prec%ictxt = ictxt
|
||||
prec%ag_data%min_coarse_size = -1
|
||||
|
||||
select case(psb_toupper(ptype(1:len_trim(ptype))))
|
||||
select case(psb_toupper(trim(ptype)))
|
||||
case ('NOPREC','NONE')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -140,6 +145,15 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_c_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_c_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_c_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('GS','FWGS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -174,6 +188,15 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_c_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-BJAC','L1_BJAC')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_c_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_c_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('AS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -202,8 +225,7 @@ subroutine mld_cprecinit(ictxt,prec,ptype,info)
|
||||
#else
|
||||
call prec%set('COARSE_SOLVE','ILU',info)
|
||||
#endif
|
||||
!call prec%precv(nlev_)%default()
|
||||
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Warning: Unknown preconditioner type request "',ptype,'"'
|
||||
|
||||
@@ -273,10 +273,12 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
|
||||
!
|
||||
! Finest level first; remember to fix base_a and base_desc
|
||||
! Finest level first; create a GEN_BLOCK
|
||||
! copy of the descriptor.
|
||||
!
|
||||
prec%precv(1)%base_a => a
|
||||
prec%precv(1)%base_desc => desc_a
|
||||
call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
newsz = 0
|
||||
array_build_loop: do i=2, iszv
|
||||
!
|
||||
@@ -317,7 +319,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Return from ',i,' call to mlprcbld ',info
|
||||
& 'Return from ',i,' call to bld_tprol', info
|
||||
!
|
||||
! Save op_prol just in case
|
||||
!
|
||||
@@ -334,9 +336,9 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
if (iaggsize <= casize) then
|
||||
newsz = i
|
||||
end if
|
||||
|
||||
if (iaggsize <= casize) newsz = i
|
||||
if (i == iszv) newsz = i
|
||||
|
||||
if (i>2) then
|
||||
if (sizeratio < mnaggratio) then
|
||||
@@ -440,7 +442,10 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
! Restart
|
||||
iszv = newsz
|
||||
! Fix the pointers, but the level 1 should
|
||||
! be already OK
|
||||
! be treated differently
|
||||
if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
end if
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
@@ -449,11 +454,6 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
! Does the coarsening need backfix on descriptors?
|
||||
do i=2, iszv
|
||||
if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
@@ -478,7 +478,7 @@ subroutine mld_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
contains
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(mld_d_onelev_type), intent(in) :: level
|
||||
type(mld_d_onelev_type), intent(inout) :: level
|
||||
class(mld_d_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
@@ -493,15 +493,19 @@ contains
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
|
||||
|
||||
allocate(save1, mold=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, mold=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(mld_d_onelev_type), intent(inout), target :: level
|
||||
class(mld_d_base_smoother_type), allocatable, intent(in) :: save1, save2
|
||||
class(mld_d_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
@@ -511,7 +515,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) allocate(level%sm,mold=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
@@ -521,7 +526,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) allocate(level%sm2a,mold=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
|
||||
@@ -256,7 +256,7 @@ subroutine mld_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but the coarse matrix has been changed to replicated'
|
||||
end if
|
||||
|
||||
case(mld_bjac_,mld_jac_, mld_l1_jac_)
|
||||
case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
|
||||
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'MLD2P4: Warning: original coarse solver was requested as ',&
|
||||
|
||||
+174
-128
@@ -194,89 +194,89 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_umf_)
|
||||
case(mld_umf_)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
|
||||
case(mld_sludist_)
|
||||
case(mld_sludist_)
|
||||
#if defined(HAVE_SLUDIST_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_jac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
@@ -287,6 +287,18 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -345,8 +357,8 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
@@ -435,6 +447,18 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
@@ -609,89 +633,88 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('UMF')
|
||||
case('UMF')
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
|
||||
case('SLUDIST')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('SLUDIST')
|
||||
#if defined(HAVE_SLUDIST_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#elif defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('JAC','JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
@@ -702,6 +725,18 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -741,9 +776,9 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
case('COARSE_SOLVE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (string)
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
@@ -827,11 +862,22 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
|
||||
case('L1-JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
|
||||
@@ -50,10 +50,15 @@
|
||||
!
|
||||
! 'DIAG', 'JACOBI' - diagonal/Jacobi
|
||||
!
|
||||
! 'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi with L1 norm correction
|
||||
!
|
||||
! 'GS', 'FBGS' - Hybrid Gauss-Seidel, also symmetrized
|
||||
!
|
||||
! 'BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks
|
||||
!
|
||||
! 'L1-BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks and L1 correction for off-diag blocks
|
||||
!
|
||||
! 'AS' - Additive Schwarz (AS), with
|
||||
! overlap 1 and ILU(0) on the local submatrices
|
||||
@@ -124,7 +129,7 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
|
||||
prec%ictxt = ictxt
|
||||
prec%ag_data%min_coarse_size = -1
|
||||
|
||||
select case(psb_toupper(ptype(1:len_trim(ptype))))
|
||||
select case(psb_toupper(trim(ptype)))
|
||||
case ('NOPREC','NONE')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -143,6 +148,15 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_d_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_d_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_d_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('GS','FWGS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -177,6 +191,15 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_d_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-BJAC','L1_BJAC')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_d_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_d_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('AS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -207,8 +230,7 @@ subroutine mld_dprecinit(ictxt,prec,ptype,info)
|
||||
#else
|
||||
call prec%set('COARSE_SOLVE','ILU',info)
|
||||
#endif
|
||||
!call prec%precv(nlev_)%default()
|
||||
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Warning: Unknown preconditioner type request "',ptype,'"'
|
||||
|
||||
@@ -273,10 +273,12 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
|
||||
!
|
||||
! Finest level first; remember to fix base_a and base_desc
|
||||
! Finest level first; create a GEN_BLOCK
|
||||
! copy of the descriptor.
|
||||
!
|
||||
prec%precv(1)%base_a => a
|
||||
prec%precv(1)%base_desc => desc_a
|
||||
call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
newsz = 0
|
||||
array_build_loop: do i=2, iszv
|
||||
!
|
||||
@@ -317,7 +319,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Return from ',i,' call to mlprcbld ',info
|
||||
& 'Return from ',i,' call to bld_tprol', info
|
||||
!
|
||||
! Save op_prol just in case
|
||||
!
|
||||
@@ -334,9 +336,9 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
if (iaggsize <= casize) then
|
||||
newsz = i
|
||||
end if
|
||||
|
||||
if (iaggsize <= casize) newsz = i
|
||||
if (i == iszv) newsz = i
|
||||
|
||||
if (i>2) then
|
||||
if (sizeratio < mnaggratio) then
|
||||
@@ -440,7 +442,10 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
! Restart
|
||||
iszv = newsz
|
||||
! Fix the pointers, but the level 1 should
|
||||
! be already OK
|
||||
! be treated differently
|
||||
if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
end if
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
@@ -449,11 +454,6 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
! Does the coarsening need backfix on descriptors?
|
||||
do i=2, iszv
|
||||
if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
@@ -478,7 +478,7 @@ subroutine mld_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
contains
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(mld_s_onelev_type), intent(in) :: level
|
||||
type(mld_s_onelev_type), intent(inout) :: level
|
||||
class(mld_s_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
@@ -493,15 +493,19 @@ contains
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
|
||||
|
||||
allocate(save1, mold=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, mold=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(mld_s_onelev_type), intent(inout), target :: level
|
||||
class(mld_s_base_smoother_type), allocatable, intent(in) :: save1, save2
|
||||
class(mld_s_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
@@ -511,7 +515,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) allocate(level%sm,mold=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
@@ -521,7 +526,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) allocate(level%sm2a,mold=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
|
||||
@@ -256,7 +256,7 @@ subroutine mld_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but the coarse matrix has been changed to replicated'
|
||||
end if
|
||||
|
||||
case(mld_bjac_,mld_jac_, mld_l1_jac_)
|
||||
case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
|
||||
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'MLD2P4: Warning: original coarse solver was requested as ',&
|
||||
|
||||
+153
-106
@@ -188,75 +188,75 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_umf_)
|
||||
case(mld_umf_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
|
||||
case(mld_sludist_)
|
||||
case(mld_sludist_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_jac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
@@ -267,6 +267,18 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -325,8 +337,8 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
@@ -401,6 +413,18 @@ subroutine mld_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
@@ -569,75 +593,75 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('UMF')
|
||||
case('UMF')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
|
||||
case('SLUDIST')
|
||||
case('SLUDIST')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('JAC','JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
@@ -648,6 +672,18 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -687,9 +723,9 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
case('COARSE_SOLVE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (string)
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
@@ -759,11 +795,22 @@ subroutine mld_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
|
||||
case('L1-JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
|
||||
@@ -50,10 +50,15 @@
|
||||
!
|
||||
! 'DIAG', 'JACOBI' - diagonal/Jacobi
|
||||
!
|
||||
! 'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi with L1 norm correction
|
||||
!
|
||||
! 'GS', 'FBGS' - Hybrid Gauss-Seidel, also symmetrized
|
||||
!
|
||||
! 'BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks
|
||||
!
|
||||
! 'L1-BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks and L1 correction for off-diag blocks
|
||||
!
|
||||
! 'AS' - Additive Schwarz (AS), with
|
||||
! overlap 1 and ILU(0) on the local submatrices
|
||||
@@ -121,7 +126,7 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
|
||||
prec%ictxt = ictxt
|
||||
prec%ag_data%min_coarse_size = -1
|
||||
|
||||
select case(psb_toupper(ptype(1:len_trim(ptype))))
|
||||
select case(psb_toupper(trim(ptype)))
|
||||
case ('NOPREC','NONE')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -140,6 +145,15 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_s_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_s_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_s_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('GS','FWGS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -174,6 +188,15 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_s_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-BJAC','L1_BJAC')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_s_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_s_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('AS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -202,8 +225,7 @@ subroutine mld_sprecinit(ictxt,prec,ptype,info)
|
||||
#else
|
||||
call prec%set('COARSE_SOLVE','ILU',info)
|
||||
#endif
|
||||
!call prec%precv(nlev_)%default()
|
||||
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Warning: Unknown preconditioner type request "',ptype,'"'
|
||||
|
||||
@@ -273,10 +273,12 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
end if
|
||||
|
||||
!
|
||||
! Finest level first; remember to fix base_a and base_desc
|
||||
! Finest level first; create a GEN_BLOCK
|
||||
! copy of the descriptor.
|
||||
!
|
||||
prec%precv(1)%base_a => a
|
||||
prec%precv(1)%base_desc => desc_a
|
||||
call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
newsz = 0
|
||||
array_build_loop: do i=2, iszv
|
||||
!
|
||||
@@ -317,7 +319,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Return from ',i,' call to mlprcbld ',info
|
||||
& 'Return from ',i,' call to bld_tprol', info
|
||||
!
|
||||
! Save op_prol just in case
|
||||
!
|
||||
@@ -334,9 +336,9 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
sizeratio = sum(prec%precv(i-1)%map%naggr)/sizeratio
|
||||
end if
|
||||
prec%precv(i)%szratio = sizeratio
|
||||
if (iaggsize <= casize) then
|
||||
newsz = i
|
||||
end if
|
||||
|
||||
if (iaggsize <= casize) newsz = i
|
||||
if (i == iszv) newsz = i
|
||||
|
||||
if (i>2) then
|
||||
if (sizeratio < mnaggratio) then
|
||||
@@ -440,7 +442,10 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
! Restart
|
||||
iszv = newsz
|
||||
! Fix the pointers, but the level 1 should
|
||||
! be already OK
|
||||
! be treated differently
|
||||
if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
|
||||
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
|
||||
end if
|
||||
do i=2, iszv
|
||||
prec%precv(i)%base_a => prec%precv(i)%ac
|
||||
prec%precv(i)%base_desc => prec%precv(i)%desc_ac
|
||||
@@ -449,11 +454,6 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
! Does the coarsening need backfix on descriptors?
|
||||
do i=2, iszv
|
||||
if (info == psb_success_) call prec%precv(i)%backfix(prec%precv(i-1),info)
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Internal hierarchy build' )
|
||||
@@ -478,7 +478,7 @@ subroutine mld_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
|
||||
contains
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(mld_z_onelev_type), intent(in) :: level
|
||||
type(mld_z_onelev_type), intent(inout) :: level
|
||||
class(mld_z_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
@@ -493,15 +493,19 @@ contains
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) allocate(save2, source=level%sm2a,stat=info)
|
||||
|
||||
allocate(save1, mold=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, mold=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(mld_z_onelev_type), intent(inout), target :: level
|
||||
class(mld_z_base_smoother_type), allocatable, intent(in) :: save1, save2
|
||||
class(mld_z_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
@@ -511,7 +515,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) allocate(level%sm,mold=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
@@ -521,7 +526,8 @@ contains
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) allocate(level%sm2a,mold=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
|
||||
@@ -256,7 +256,7 @@ subroutine mld_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but the coarse matrix has been changed to replicated'
|
||||
end if
|
||||
|
||||
case(mld_bjac_,mld_jac_, mld_l1_jac_)
|
||||
case(mld_bjac_,mld_l1_bjac_,mld_jac_, mld_l1_jac_, mld_gs_, mld_fbgs_, mld_l1_gs_,mld_l1_fbgs_)
|
||||
if (prec%precv(iszv)%parms%coarse_mat /= mld_distr_mat_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'MLD2P4: Warning: original coarse solver was requested as ',&
|
||||
|
||||
+174
-128
@@ -194,89 +194,89 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info)
|
||||
case(mld_slu_)
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
case(mld_ilu_n_, mld_ilu_t_,mld_milu_n_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
case(mld_mumps_)
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_umf_)
|
||||
case(mld_umf_)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
|
||||
case(mld_sludist_)
|
||||
case(mld_sludist_)
|
||||
#if defined(HAVE_SLUDIST_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
#endif
|
||||
case(mld_jac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
@@ -287,6 +287,18 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -345,8 +357,8 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos)
|
||||
select case (val)
|
||||
case(mld_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
case(mld_bjac_,mld_l1_bjac_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',val,info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
@@ -435,6 +447,18 @@ subroutine mld_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_l1_diag_scale_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_gs_,mld_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_bwgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_bwgs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
case(mld_l1_gs_,mld_l1_fbgs_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_l1_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',mld_gs_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
@@ -609,89 +633,88 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
#endif
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
call p%precv(nlev_)%set('COARSE_MAT','dist',info)
|
||||
case('SLU')
|
||||
#if defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
case('ILU','MILU','ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','bjac',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
case('MUMPS')
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC'_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('UMF')
|
||||
case('UMF')
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
|
||||
case('SLUDIST')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('SLUDIST')
|
||||
#if defined(HAVE_SLUDIST_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',string,info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#elif defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','SLU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','REPL',info,pos=pos)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','MUMPS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','ILU',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
#endif
|
||||
case('JAC','JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
@@ -702,6 +725,18 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
|
||||
endif
|
||||
@@ -741,9 +776,9 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
case('COARSE_SOLVE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('COARSE_SOLVE',string,info,pos=pos)
|
||||
select case (string)
|
||||
case('BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
select case (psb_toupper(trim(string)))
|
||||
case('BJAC', 'L1-BJAC')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',psb_toupper(trim(string)),info,pos=pos)
|
||||
#if defined(HAVE_UMF_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','UMF',info,pos=pos)
|
||||
#elif defined(HAVE_SLU_)
|
||||
@@ -827,11 +862,22 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
|
||||
case('L1-JACOBI')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','L1-DIAG',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('GS','FWGS','FBGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('BWGS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','BWGS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
case('L1-GS')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE','L1-BJAC',info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE','GS',info,pos=pos)
|
||||
call p%precv(nlev_)%set('COARSE_MAT','DIST',info,pos=pos)
|
||||
end select
|
||||
endif
|
||||
|
||||
|
||||
@@ -50,10 +50,15 @@
|
||||
!
|
||||
! 'DIAG', 'JACOBI' - diagonal/Jacobi
|
||||
!
|
||||
! 'L1-DIAG', 'L1-JACOBI' - diagonal/Jacobi with L1 norm correction
|
||||
!
|
||||
! 'GS', 'FBGS' - Hybrid Gauss-Seidel, also symmetrized
|
||||
!
|
||||
! 'BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks
|
||||
!
|
||||
! 'L1-BJAC' - block Jacobi preconditioner, with ILU(0)
|
||||
! on the local blocks and L1 correction for off-diag blocks
|
||||
!
|
||||
! 'AS' - Additive Schwarz (AS), with
|
||||
! overlap 1 and ILU(0) on the local submatrices
|
||||
@@ -124,7 +129,7 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
|
||||
prec%ictxt = ictxt
|
||||
prec%ag_data%min_coarse_size = -1
|
||||
|
||||
select case(psb_toupper(ptype(1:len_trim(ptype))))
|
||||
select case(psb_toupper(trim(ptype)))
|
||||
case ('NOPREC','NONE')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -143,6 +148,15 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_z_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_z_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_z_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('GS','FWGS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -177,6 +191,15 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
|
||||
allocate(mld_z_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-BJAC','L1_BJAC')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(mld_z_l1_jac_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(mld_z_ilu_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('AS')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
@@ -207,8 +230,7 @@ subroutine mld_zprecinit(ictxt,prec,ptype,info)
|
||||
#else
|
||||
call prec%set('COARSE_SOLVE','ILU',info)
|
||||
#endif
|
||||
!call prec%precv(nlev_)%default()
|
||||
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) name,&
|
||||
&': Warning: Unknown preconditioner type request "',ptype,'"'
|
||||
|
||||
@@ -12,6 +12,8 @@ mld_c_as_smoother_apply_vect.o \
|
||||
mld_c_as_smoother_bld.o \
|
||||
mld_c_as_smoother_check.o \
|
||||
mld_c_as_smoother_clone.o \
|
||||
mld_c_as_smoother_clone_settings.o \
|
||||
mld_c_as_smoother_clear_data.o \
|
||||
mld_c_as_smoother_cnv.o \
|
||||
mld_c_as_smoother_csetc.o \
|
||||
mld_c_as_smoother_cseti.o \
|
||||
@@ -26,6 +28,8 @@ mld_c_base_smoother_apply_vect.o \
|
||||
mld_c_base_smoother_bld.o \
|
||||
mld_c_base_smoother_check.o \
|
||||
mld_c_base_smoother_clone.o \
|
||||
mld_c_base_smoother_clone_settings.o \
|
||||
mld_c_base_smoother_clear_data.o \
|
||||
mld_c_base_smoother_cnv.o \
|
||||
mld_c_base_smoother_csetc.o \
|
||||
mld_c_base_smoother_cseti.o \
|
||||
@@ -39,15 +43,22 @@ mld_c_jac_smoother_bld.o \
|
||||
mld_c_jac_smoother_descr.o \
|
||||
mld_c_jac_smoother_dmp.o \
|
||||
mld_c_jac_smoother_clone.o \
|
||||
mld_c_jac_smoother_clone_settings.o \
|
||||
mld_c_jac_smoother_clear_data.o \
|
||||
mld_c_jac_smoother_cnv.o \
|
||||
mld_c_jac_smoother_csetc.o \
|
||||
mld_c_jac_smoother_cseti.o \
|
||||
mld_c_jac_smoother_csetr.o \
|
||||
mld_c_l1_jac_smoother_bld.o \
|
||||
mld_c_l1_jac_smoother_descr.o \
|
||||
mld_c_l1_jac_smoother_clone.o \
|
||||
mld_d_as_smoother_apply.o \
|
||||
mld_d_as_smoother_apply_vect.o \
|
||||
mld_d_as_smoother_bld.o \
|
||||
mld_d_as_smoother_check.o \
|
||||
mld_d_as_smoother_clone.o \
|
||||
mld_d_as_smoother_clone_settings.o \
|
||||
mld_d_as_smoother_clear_data.o \
|
||||
mld_d_as_smoother_cnv.o \
|
||||
mld_d_as_smoother_csetc.o \
|
||||
mld_d_as_smoother_cseti.o \
|
||||
@@ -62,6 +73,8 @@ mld_d_base_smoother_apply_vect.o \
|
||||
mld_d_base_smoother_bld.o \
|
||||
mld_d_base_smoother_check.o \
|
||||
mld_d_base_smoother_clone.o \
|
||||
mld_d_base_smoother_clone_settings.o \
|
||||
mld_d_base_smoother_clear_data.o \
|
||||
mld_d_base_smoother_cnv.o \
|
||||
mld_d_base_smoother_csetc.o \
|
||||
mld_d_base_smoother_cseti.o \
|
||||
@@ -75,15 +88,22 @@ mld_d_jac_smoother_bld.o \
|
||||
mld_d_jac_smoother_descr.o \
|
||||
mld_d_jac_smoother_dmp.o \
|
||||
mld_d_jac_smoother_clone.o \
|
||||
mld_d_jac_smoother_clone_settings.o \
|
||||
mld_d_jac_smoother_clear_data.o \
|
||||
mld_d_jac_smoother_cnv.o \
|
||||
mld_d_jac_smoother_csetc.o \
|
||||
mld_d_jac_smoother_cseti.o \
|
||||
mld_d_jac_smoother_csetr.o \
|
||||
mld_d_l1_jac_smoother_bld.o \
|
||||
mld_d_l1_jac_smoother_descr.o \
|
||||
mld_d_l1_jac_smoother_clone.o \
|
||||
mld_s_as_smoother_apply.o \
|
||||
mld_s_as_smoother_apply_vect.o \
|
||||
mld_s_as_smoother_bld.o \
|
||||
mld_s_as_smoother_check.o \
|
||||
mld_s_as_smoother_clone.o \
|
||||
mld_s_as_smoother_clone_settings.o \
|
||||
mld_s_as_smoother_clear_data.o \
|
||||
mld_s_as_smoother_cnv.o \
|
||||
mld_s_as_smoother_csetc.o \
|
||||
mld_s_as_smoother_cseti.o \
|
||||
@@ -98,6 +118,8 @@ mld_s_base_smoother_apply_vect.o \
|
||||
mld_s_base_smoother_bld.o \
|
||||
mld_s_base_smoother_check.o \
|
||||
mld_s_base_smoother_clone.o \
|
||||
mld_s_base_smoother_clone_settings.o \
|
||||
mld_s_base_smoother_clear_data.o \
|
||||
mld_s_base_smoother_cnv.o \
|
||||
mld_s_base_smoother_csetc.o \
|
||||
mld_s_base_smoother_cseti.o \
|
||||
@@ -111,15 +133,22 @@ mld_s_jac_smoother_bld.o \
|
||||
mld_s_jac_smoother_descr.o \
|
||||
mld_s_jac_smoother_dmp.o \
|
||||
mld_s_jac_smoother_clone.o \
|
||||
mld_s_jac_smoother_clone_settings.o \
|
||||
mld_s_jac_smoother_clear_data.o \
|
||||
mld_s_jac_smoother_cnv.o \
|
||||
mld_s_jac_smoother_csetc.o \
|
||||
mld_s_jac_smoother_cseti.o \
|
||||
mld_s_jac_smoother_csetr.o \
|
||||
mld_s_l1_jac_smoother_bld.o \
|
||||
mld_s_l1_jac_smoother_descr.o \
|
||||
mld_s_l1_jac_smoother_clone.o \
|
||||
mld_z_as_smoother_apply.o \
|
||||
mld_z_as_smoother_apply_vect.o \
|
||||
mld_z_as_smoother_bld.o \
|
||||
mld_z_as_smoother_check.o \
|
||||
mld_z_as_smoother_clone.o \
|
||||
mld_z_as_smoother_clone_settings.o \
|
||||
mld_z_as_smoother_clear_data.o \
|
||||
mld_z_as_smoother_cnv.o \
|
||||
mld_z_as_smoother_csetc.o \
|
||||
mld_z_as_smoother_cseti.o \
|
||||
@@ -134,6 +163,8 @@ mld_z_base_smoother_apply_vect.o \
|
||||
mld_z_base_smoother_bld.o \
|
||||
mld_z_base_smoother_check.o \
|
||||
mld_z_base_smoother_clone.o \
|
||||
mld_z_base_smoother_clone_settings.o \
|
||||
mld_z_base_smoother_clear_data.o \
|
||||
mld_z_base_smoother_cnv.o \
|
||||
mld_z_base_smoother_csetc.o \
|
||||
mld_z_base_smoother_cseti.o \
|
||||
@@ -147,10 +178,15 @@ mld_z_jac_smoother_bld.o \
|
||||
mld_z_jac_smoother_descr.o \
|
||||
mld_z_jac_smoother_dmp.o \
|
||||
mld_z_jac_smoother_clone.o \
|
||||
mld_z_jac_smoother_clone_settings.o \
|
||||
mld_z_jac_smoother_clear_data.o \
|
||||
mld_z_jac_smoother_cnv.o \
|
||||
mld_z_jac_smoother_csetc.o \
|
||||
mld_z_jac_smoother_cseti.o \
|
||||
mld_z_jac_smoother_csetr.o
|
||||
mld_z_jac_smoother_csetr.o \
|
||||
mld_z_l1_jac_smoother_bld.o \
|
||||
mld_z_l1_jac_smoother_descr.o \
|
||||
mld_z_l1_jac_smoother_clone.o \
|
||||
|
||||
LIBNAME=libmld_prec.a
|
||||
|
||||
|
||||
@@ -105,116 +105,218 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
if (.false.) then
|
||||
if (sweeps > 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%pa,y,cone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,ww,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(cone,x,czero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
end do
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
|
||||
endif
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
end if
|
||||
|
||||
|
||||
if (.not.(4*isz <= size(work))) then
|
||||
deallocate(aux,stat=info)
|
||||
endif
|
||||
|
||||
@@ -107,89 +107,140 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
if (.true.) then
|
||||
|
||||
if (sweeps > 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
end if
|
||||
|
||||
!
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%pa,y,cone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,ww,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(cone,x,czero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%pa,ty,cone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -197,47 +248,125 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
endif
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
end if
|
||||
|
||||
if (.not.(4*isz <= size(work))) then
|
||||
deallocate(aux,stat=info)
|
||||
|
||||
@@ -66,7 +66,7 @@ subroutine mld_c_as_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
|
||||
sm%pa => a
|
||||
novr = sm%novr
|
||||
if (novr < 0) then
|
||||
info=psb_err_invalid_ovr_num_
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_as_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_as_smoother, mld_protect_name => mld_c_as_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_c_as_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_as_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call sm%desc_data%free(info)
|
||||
if ((info==0).and.allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_c_as_smoother_clear_data
|
||||
@@ -77,6 +77,7 @@ subroutine mld_c_as_smoother_clone(sm,smout,info)
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
smo%pa => sm%pa
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
|
||||
@@ -0,0 +1,95 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! asd on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_as_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_as_smoother, mld_protect_name => mld_c_as_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_c_as_smoother_type), intent(inout) :: sm
|
||||
class(mld_c_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_as_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(smout)
|
||||
class is(mld_c_as_smoother_type)
|
||||
smout%novr = sm%novr
|
||||
smout%restr = sm%restr
|
||||
smout%prol = sm%prol
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_c_as_smoother_clone_settings
|
||||
@@ -35,21 +35,22 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_c_as_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_dmp
|
||||
implicit none
|
||||
class(mld_c_as_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,7 +60,7 @@ subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
else
|
||||
prefix_ = "dump_smth_c"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(smoother)) then
|
||||
@@ -67,11 +68,18 @@ subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
else
|
||||
smoother_ = .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_)
|
||||
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
|
||||
lname = lname + 5
|
||||
|
||||
if (global_num_) then
|
||||
write(0,*) iam,' Warning: no global num with AS smoothers dump'
|
||||
end if
|
||||
if (smoother_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
|
||||
if (sm%nd%is_asb()) &
|
||||
@@ -79,6 +87,6 @@ subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
end if
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_c_as_smoother_dmp
|
||||
|
||||
@@ -61,6 +61,7 @@ subroutine mld_c_as_smoother_free(sm,info)
|
||||
end if
|
||||
end if
|
||||
call sm%nd%free()
|
||||
sm%pa => null()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -0,0 +1,67 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_base_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_c_base_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_base_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_c_base_smoother_clear_data
|
||||
@@ -45,7 +45,7 @@ subroutine mld_c_base_smoother_clone(sm,smout,info)
|
||||
class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_smoother_clone'
|
||||
character(len=20) :: name='c_base_smoother_clone'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
@@ -0,0 +1,89 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_base_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_c_base_smoother_type), intent(inout) :: sm
|
||||
class(mld_c_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_base_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info=psb_success_
|
||||
if (same_type_as(sm,smout)) then
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_c_base_smoother_clone_settings
|
||||
@@ -48,7 +48,7 @@ subroutine mld_c_base_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_smoother_cnv'
|
||||
character(len=20) :: name='c_base_smoother_cnv'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
@@ -35,21 +35,22 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_c_base_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_dmp
|
||||
implicit none
|
||||
class(mld_c_base_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,9 +60,14 @@ subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
|
||||
else
|
||||
prefix_ = "dump_smth_c"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
if (present(smoother)) then
|
||||
smoother_ = smoother
|
||||
else
|
||||
@@ -74,6 +80,6 @@ subroutine mld_c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
|
||||
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_c_base_smoother_dmp
|
||||
|
||||
@@ -65,7 +65,7 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
ictxt = desc_data%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
|
||||
|
||||
|
||||
if (present(init)) then
|
||||
init_ = psb_toupper(init)
|
||||
else
|
||||
@@ -102,146 +102,63 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
|
||||
! if .not.sv%is_iterative, there's no need to pass init
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,&
|
||||
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
|
||||
if (sweeps > 0) then
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
if (associated(sm%pa)) then
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! This means we are dealing with a pure Jacobi smoother/solver.
|
||||
! Compute Y(j+1) = Y(j)+ M^(-1)*(X-A*Y(j)),
|
||||
!
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of a block-Jacobi solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one AXPBY and one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
|
||||
deallocate(tx,ty,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
@@ -250,6 +167,12 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
|
||||
@@ -49,7 +49,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
type(psb_c_vect_type),intent(inout) :: y
|
||||
complex(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
complex(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_c_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -108,190 +108,90 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if(sm%checkres) then
|
||||
call psb_geall(r,desc_data,info)
|
||||
call psb_geasb(r,desc_data,info)
|
||||
resdenum = psb_genrm2(x,desc_data,info)
|
||||
end if
|
||||
if (sweeps > 0) then
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
|
||||
! if .not.sv%is_iterative, there's no need to pass init
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
if(sm%checkres) then
|
||||
call psb_geall(r,desc_data,info)
|
||||
call psb_geasb(r,desc_data,info)
|
||||
resdenum = psb_genrm2(x,desc_data,info)
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,&
|
||||
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_c_diag_solver_type)
|
||||
!
|
||||
! This means we are dealing with a pure Jacobi smoother/solver.
|
||||
!
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
|
||||
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(cone,x,czero,r,r,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if ( res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,tx,cone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(cone,x,czero,r,r,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if ( res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
|
||||
end associate
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
class default
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of a block-Jacobi solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 2) then
|
||||
info = psb_err_internal_error_
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one AXPBY and one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
end associate
|
||||
|
||||
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
|
||||
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
|
||||
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(cone,x,czero,r,r,desc_data,info)
|
||||
call psb_spmm(-cone,sm%pa,ty,cone,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if (res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
end associate
|
||||
end select
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
|
||||
@@ -51,9 +51,8 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
! Local variables
|
||||
type(psb_cspmat_type) :: tmpa
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
|
||||
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
|
||||
type(psb_c_coo_sparse_mat) :: tmpcoo
|
||||
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
|
||||
character(len=20) :: name='c_jac_smoother_bld', ch_err
|
||||
|
||||
@@ -72,19 +71,23 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
nrow_a = a%get_nrows()
|
||||
nztota = a%get_nzeros()
|
||||
|
||||
if( sm%checkres ) sm%pa => a
|
||||
sm%pa => a
|
||||
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_c_diag_solver_type)
|
||||
call sm%nd%free()
|
||||
sm%pa => a
|
||||
sm%nd_nnz_tot = nztota
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
|
||||
class default
|
||||
if (smsv%is_global()) then
|
||||
! Do not put anything into SM%ND since the solver
|
||||
! is acting globally.
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
else
|
||||
call a%csclip(sm%nd,info,&
|
||||
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
|
||||
@@ -98,6 +101,10 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
endif
|
||||
end if
|
||||
sm%nd_nnz_tot = sm%nd%get_nzeros()
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call a%csclip(tmpa,info,&
|
||||
& jmax=nrow_a,rscale=.false.,cscale=.false.)
|
||||
call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold)
|
||||
end if
|
||||
end select
|
||||
if (info /= psb_success_) then
|
||||
@@ -105,15 +112,7 @@ subroutine mld_c_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
& a_err='clip & psb_spcnv csr 4')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
|
||||
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='solver build')
|
||||
goto 9999
|
||||
end if
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_jac_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_c_jac_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_jac_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
sm%pa => null()
|
||||
if ((info==0).and.allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_c_jac_smoother_clear_data
|
||||
@@ -1,15 +1,15 @@
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
@@ -21,7 +21,7 @@
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
@@ -33,10 +33,10 @@
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
subroutine mld_c_jac_smoother_clone(sm,smout,info)
|
||||
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_clone
|
||||
|
||||
@@ -59,19 +59,25 @@ subroutine mld_c_jac_smoother_clone(sm,smout,info)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& allocate(mld_c_jac_smoother_type :: smout, stat=info)
|
||||
if (info /= 0) then
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
goto 9999
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
select type(smo => smout)
|
||||
type is (mld_c_jac_smoother_type)
|
||||
smo%nd_nnz_tot = sm%nd_nnz_tot
|
||||
smo%checkres = sm%checkres
|
||||
smo%printres = sm%printres
|
||||
smo%checkiter = sm%checkiter
|
||||
smo%printiter = sm%printiter
|
||||
smo%tol = sm%tol
|
||||
call sm%nd%clone(smo%nd,info)
|
||||
if ((info==psb_success_).and.(allocated(sm%sv))) then
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
smo%pa => sm%pa
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
|
||||
@@ -0,0 +1,101 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! asd on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_jac_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_c_jac_smoother_type), intent(inout) :: sm
|
||||
class(mld_c_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_jac_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(smout)
|
||||
class is(mld_c_jac_smoother_type)
|
||||
|
||||
smout%pa => null()
|
||||
smout%nd_nnz_tot = 0
|
||||
smout%checkres = sm%checkres
|
||||
smout%printres = sm%printres
|
||||
smout%checkiter = sm%checkiter
|
||||
smout%printiter = sm%printiter
|
||||
smout%tol = sm%tol
|
||||
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_c_jac_smoother_clone_settings
|
||||
@@ -59,7 +59,7 @@ subroutine mld_c_jac_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
|
||||
|
||||
if (info == psb_success_) then
|
||||
if ((.not.associated(sm%pa)).and.(sm%nd%is_asb())) then
|
||||
if (sm%nd%is_asb()) then
|
||||
if (present(amold)) then
|
||||
call sm%nd%cscnv(info,&
|
||||
& mold=amold,dupl=psb_dupl_add_)
|
||||
|
||||
@@ -52,22 +52,27 @@ subroutine mld_c_jac_smoother_csetc(sm,what,val,info,idx)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SMOOTHER_STOP')
|
||||
if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
|
||||
sm%checkres = .true.
|
||||
else
|
||||
sm%checkres = .false.
|
||||
end if
|
||||
case('SMOOTHER_TRACE')
|
||||
if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
|
||||
sm%printres = .true.
|
||||
else
|
||||
sm%printres = .false.
|
||||
end if
|
||||
case default
|
||||
call sm%mld_c_base_smoother_type%set(what,val,info,idx=idx)
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SMOOTHER_STOP')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('T','TRUE')
|
||||
sm%checkres = .true.
|
||||
case('F','FALSE')
|
||||
sm%checkres = .false.
|
||||
case default
|
||||
write(0,*) 'Unknown value for smoother_stop : "',psb_toupper(trim(val)),'"'
|
||||
end select
|
||||
case('SMOOTHER_TRACE')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('T','TRUE')
|
||||
sm%printres = .true.
|
||||
case('F','FALSE')
|
||||
sm%printres = .false.
|
||||
case default
|
||||
write(0,*) 'Unknown value for smoother_trace : "',psb_toupper(trim(val)),'"'
|
||||
end select
|
||||
case default
|
||||
call sm%mld_c_base_smoother_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) then
|
||||
|
||||
@@ -35,21 +35,23 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_c_jac_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_jac_smoother, mld_protect_nam => mld_c_jac_smoother_dmp
|
||||
implicit none
|
||||
class(mld_c_jac_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
integer(psb_lpk_), allocatable :: iv(:)
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,7 +61,7 @@ subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
|
||||
else
|
||||
prefix_ = "dump_smth_c"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(smoother)) then
|
||||
@@ -67,6 +69,11 @@ subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
|
||||
else
|
||||
smoother_ = .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_)
|
||||
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
|
||||
@@ -74,11 +81,17 @@ subroutine mld_c_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
|
||||
|
||||
if (smoother_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
|
||||
if (sm%nd%is_asb()) &
|
||||
& call sm%nd%print(fname,head=head)
|
||||
if (global_num_) then
|
||||
iv = desc%get_global_indices(owned=.false.)
|
||||
if (sm%nd%is_asb()) &
|
||||
& call sm%nd%print(fname,head=head,iv=iv)
|
||||
else
|
||||
if (sm%nd%is_asb()) &
|
||||
& call sm%nd%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_c_jac_smoother_dmp
|
||||
|
||||
@@ -0,0 +1,175 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_diag_solver
|
||||
use mld_c_jac_smoother, mld_protect_name => mld_c_l1_jac_smoother_bld
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(psb_cspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(mld_c_l1_jac_smoother_type), intent(inout) :: sm
|
||||
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
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
|
||||
real(psb_spk_), allocatable :: arwsum(:)
|
||||
type(psb_cspmat_type) :: tmpa
|
||||
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
|
||||
character(len=20) :: name='c_l1_jac_smoother_bld', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
|
||||
n_row = desc_a%get_local_rows()
|
||||
n_col = desc_a%get_local_cols()
|
||||
nrow_a = a%get_nrows()
|
||||
nztota = a%get_nzeros()
|
||||
|
||||
sm%pa => a
|
||||
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_c_diag_solver_type)
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = nztota
|
||||
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
|
||||
class default
|
||||
if (smsv%is_global()) then
|
||||
! Do not put anything into SM%ND since the solver
|
||||
! is acting globally.
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
else
|
||||
|
||||
call a%csclip(tmpa,info,&
|
||||
& jmax=nrow_a,rscale=.false.,cscale=.false.)
|
||||
|
||||
call a%csclip(sm%nd,info,&
|
||||
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
|
||||
|
||||
arwsum = sm%nd%arwsum(info)
|
||||
|
||||
call combine_dl1(-sone,arwsum,sm%nd,info)
|
||||
call combine_dl1(sone,arwsum,tmpa,info)
|
||||
|
||||
sm%nd_nnz_tot = sm%nd%get_nzeros()
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
|
||||
call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold)
|
||||
|
||||
if (info == psb_success_) then
|
||||
if (present(amold)) then
|
||||
call sm%nd%cscnv(info,&
|
||||
& mold=amold,dupl=psb_dupl_add_)
|
||||
else
|
||||
call sm%nd%cscnv(info,&
|
||||
& type='csr',dupl=psb_dupl_add_)
|
||||
endif
|
||||
end if
|
||||
end if
|
||||
end select
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='clip & psb_spcnv csr 4')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='solver build')
|
||||
goto 9999
|
||||
end if
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine combine_dl1(alpha,dl1,mat,info)
|
||||
implicit none
|
||||
real(psb_spk_), intent(in) :: alpha, dl1(:)
|
||||
type(psb_cspmat_type), intent(inout) :: mat
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: k, nz, nrm, dp
|
||||
type(psb_c_coo_sparse_mat) :: tcoo
|
||||
|
||||
call mat%mv_to(tcoo)
|
||||
nz = tcoo%get_nzeros()
|
||||
nrm = min(size(dl1),tcoo%get_nrows(),tcoo%get_ncols())
|
||||
!!$ write(0,*) 'Check on combine_dl1: ',nrm, tcoo%get_nrows(),tcoo%get_ncols(), nz
|
||||
call tcoo%ensure_size(nz+nrm)
|
||||
call tcoo%set_dupl(psb_dupl_add_)
|
||||
do k=1,nrm
|
||||
if (dl1(k) /= szero) then
|
||||
nz = nz + 1
|
||||
tcoo%ia(nz) = k
|
||||
tcoo%ja(nz) = k
|
||||
tcoo%val(nz) = alpha*dl1(k)
|
||||
end if
|
||||
end do
|
||||
call tcoo%set_nzeros(nz)
|
||||
call tcoo%fix(info)
|
||||
call mat%mv_from(tcoo)
|
||||
end subroutine combine_dl1
|
||||
|
||||
|
||||
end subroutine mld_c_l1_jac_smoother_bld
|
||||
@@ -0,0 +1,93 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_l1_jac_smoother_clone(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_jac_smoother, mld_protect_name => mld_c_l1_jac_smoother_clone
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_c_l1_jac_smoother_type), intent(inout) :: sm
|
||||
class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (allocated(smout)) then
|
||||
call smout%free(info)
|
||||
if (info == psb_success_) deallocate(smout, stat=info)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& allocate(mld_c_l1_jac_smoother_type :: smout, stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
select type(smo => smout)
|
||||
type is (mld_c_l1_jac_smoother_type)
|
||||
smo%nd_nnz_tot = sm%nd_nnz_tot
|
||||
smo%checkres = sm%checkres
|
||||
smo%printres = sm%printres
|
||||
smo%checkiter = sm%checkiter
|
||||
smo%printiter = sm%printiter
|
||||
smo%tol = sm%tol
|
||||
call sm%nd%clone(smo%nd,info)
|
||||
if ((info==psb_success_).and.(allocated(sm%sv))) then
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_c_l1_jac_smoother_clone
|
||||
@@ -0,0 +1,103 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_c_l1_jac_smoother_descr(sm,info,iout,coarse)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_c_diag_solver
|
||||
use mld_c_jac_smoother, mld_protect_name => mld_c_l1_jac_smoother_descr
|
||||
use mld_c_diag_solver
|
||||
use mld_c_gs_solver
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_c_l1_jac_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='mld_c_l1_jac_smoother_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
logical :: coarse_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(coarse)) then
|
||||
coarse_ = coarse
|
||||
else
|
||||
coarse_ = .false.
|
||||
end if
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
if (.not.coarse_) then
|
||||
if (allocated(sm%sv)) then
|
||||
select type(smv=>sm%sv)
|
||||
class is (mld_c_diag_solver_type)
|
||||
write(iout_,*) ' Point Jacobi '
|
||||
write(iout_,*) ' Local diagonal:'
|
||||
call smv%descr(info,iout_,coarse=coarse)
|
||||
class is (mld_c_bwgs_solver_type)
|
||||
write(iout_,*) ' L1-Hybrid Backward Gauss-Seidel '
|
||||
class is (mld_c_gs_solver_type)
|
||||
write(iout_,*) ' L1-Hybrid Forward Gauss-Seidel '
|
||||
class default
|
||||
write(iout_,*) ' L1-Block Jacobi '
|
||||
write(iout_,*) ' Local solver details:'
|
||||
call smv%descr(info,iout_,coarse=coarse)
|
||||
end select
|
||||
|
||||
else
|
||||
write(iout_,*) ' L1-Block Jacobi '
|
||||
end if
|
||||
else
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%descr(info,iout_,coarse=coarse)
|
||||
end if
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine mld_c_l1_jac_smoother_descr
|
||||
@@ -105,116 +105,218 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
if (.false.) then
|
||||
if (sweeps > 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%pa,y,done,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,ww,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%pa,ty,done,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(done,x,dzero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%pa,ty,done,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
end do
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
|
||||
endif
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
end if
|
||||
|
||||
|
||||
if (.not.(4*isz <= size(work))) then
|
||||
deallocate(aux,stat=info)
|
||||
endif
|
||||
|
||||
@@ -107,89 +107,140 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
if (.true.) then
|
||||
|
||||
if (sweeps > 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
end if
|
||||
|
||||
!
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%pa,y,done,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,ww,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%pa,ty,done,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(done,x,dzero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%pa,ty,done,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -197,47 +248,125 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
endif
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
end if
|
||||
|
||||
if (.not.(4*isz <= size(work))) then
|
||||
deallocate(aux,stat=info)
|
||||
|
||||
@@ -66,7 +66,7 @@ subroutine mld_d_as_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
|
||||
sm%pa => a
|
||||
novr = sm%novr
|
||||
if (novr < 0) then
|
||||
info=psb_err_invalid_ovr_num_
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_as_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_as_smoother, mld_protect_name => mld_d_as_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_d_as_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_as_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call sm%desc_data%free(info)
|
||||
if ((info==0).and.allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_d_as_smoother_clear_data
|
||||
@@ -77,6 +77,7 @@ subroutine mld_d_as_smoother_clone(sm,smout,info)
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
smo%pa => sm%pa
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
|
||||
@@ -0,0 +1,95 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! asd on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_as_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_as_smoother, mld_protect_name => mld_d_as_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_d_as_smoother_type), intent(inout) :: sm
|
||||
class(mld_d_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_as_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(smout)
|
||||
class is(mld_d_as_smoother_type)
|
||||
smout%novr = sm%novr
|
||||
smout%restr = sm%restr
|
||||
smout%prol = sm%prol
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_d_as_smoother_clone_settings
|
||||
@@ -35,21 +35,22 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_d_as_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_dmp
|
||||
implicit none
|
||||
class(mld_d_as_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,7 +60,7 @@ subroutine mld_d_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
else
|
||||
prefix_ = "dump_smth_d"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(smoother)) then
|
||||
@@ -67,11 +68,18 @@ subroutine mld_d_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
else
|
||||
smoother_ = .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_)
|
||||
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
|
||||
lname = lname + 5
|
||||
|
||||
if (global_num_) then
|
||||
write(0,*) iam,' Warning: no global num with AS smoothers dump'
|
||||
end if
|
||||
if (smoother_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
|
||||
if (sm%nd%is_asb()) &
|
||||
@@ -79,6 +87,6 @@ subroutine mld_d_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
end if
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_d_as_smoother_dmp
|
||||
|
||||
@@ -61,6 +61,7 @@ subroutine mld_d_as_smoother_free(sm,info)
|
||||
end if
|
||||
end if
|
||||
call sm%nd%free()
|
||||
sm%pa => null()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -0,0 +1,67 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_base_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_d_base_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_d_base_smoother_clear_data
|
||||
@@ -0,0 +1,89 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_base_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_d_base_smoother_type), intent(inout) :: sm
|
||||
class(mld_d_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info=psb_success_
|
||||
if (same_type_as(sm,smout)) then
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_d_base_smoother_clone_settings
|
||||
@@ -35,21 +35,22 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_d_base_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_dmp
|
||||
implicit none
|
||||
class(mld_d_base_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,9 +60,14 @@ subroutine mld_d_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
|
||||
else
|
||||
prefix_ = "dump_smth_d"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
if (present(smoother)) then
|
||||
smoother_ = smoother
|
||||
else
|
||||
@@ -74,6 +80,6 @@ subroutine mld_d_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
|
||||
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_d_base_smoother_dmp
|
||||
|
||||
@@ -65,7 +65,7 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
ictxt = desc_data%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
|
||||
|
||||
|
||||
if (present(init)) then
|
||||
init_ = psb_toupper(init)
|
||||
else
|
||||
@@ -102,146 +102,63 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
|
||||
! if .not.sv%is_iterative, there's no need to pass init
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,&
|
||||
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
|
||||
if (sweeps > 0) then
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
if (associated(sm%pa)) then
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! This means we are dealing with a pure Jacobi smoother/solver.
|
||||
! Compute Y(j+1) = Y(j)+ M^(-1)*(X-A*Y(j)),
|
||||
!
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of a block-Jacobi solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one AXPBY and one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
|
||||
deallocate(tx,ty,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
@@ -250,6 +167,12 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
|
||||
@@ -49,7 +49,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
type(psb_d_vect_type),intent(inout) :: y
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_d_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -108,190 +108,90 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if(sm%checkres) then
|
||||
call psb_geall(r,desc_data,info)
|
||||
call psb_geasb(r,desc_data,info)
|
||||
resdenum = psb_genrm2(x,desc_data,info)
|
||||
end if
|
||||
if (sweeps > 0) then
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
|
||||
! if .not.sv%is_iterative, there's no need to pass init
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
if(sm%checkres) then
|
||||
call psb_geall(r,desc_data,info)
|
||||
call psb_geasb(r,desc_data,info)
|
||||
resdenum = psb_genrm2(x,desc_data,info)
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,&
|
||||
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_d_diag_solver_type)
|
||||
!
|
||||
! This means we are dealing with a pure Jacobi smoother/solver.
|
||||
!
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
|
||||
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(done,x,dzero,r,r,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if ( res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,tx,done,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(done,x,dzero,r,r,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if ( res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
|
||||
end associate
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
class default
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of a block-Jacobi solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 2) then
|
||||
info = psb_err_internal_error_
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one AXPBY and one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
end associate
|
||||
|
||||
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
|
||||
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
|
||||
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(done,x,dzero,r,r,desc_data,info)
|
||||
call psb_spmm(-done,sm%pa,ty,done,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if (res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
end associate
|
||||
end select
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
|
||||
@@ -51,9 +51,8 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
! Local variables
|
||||
type(psb_dspmat_type) :: tmpa
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
|
||||
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
|
||||
type(psb_d_coo_sparse_mat) :: tmpcoo
|
||||
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
|
||||
character(len=20) :: name='d_jac_smoother_bld', ch_err
|
||||
|
||||
@@ -72,19 +71,23 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
nrow_a = a%get_nrows()
|
||||
nztota = a%get_nzeros()
|
||||
|
||||
if( sm%checkres ) sm%pa => a
|
||||
sm%pa => a
|
||||
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_d_diag_solver_type)
|
||||
call sm%nd%free()
|
||||
sm%pa => a
|
||||
sm%nd_nnz_tot = nztota
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
|
||||
class default
|
||||
if (smsv%is_global()) then
|
||||
! Do not put anything into SM%ND since the solver
|
||||
! is acting globally.
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
else
|
||||
call a%csclip(sm%nd,info,&
|
||||
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
|
||||
@@ -98,6 +101,10 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
endif
|
||||
end if
|
||||
sm%nd_nnz_tot = sm%nd%get_nzeros()
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call a%csclip(tmpa,info,&
|
||||
& jmax=nrow_a,rscale=.false.,cscale=.false.)
|
||||
call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold)
|
||||
end if
|
||||
end select
|
||||
if (info /= psb_success_) then
|
||||
@@ -105,15 +112,7 @@ subroutine mld_d_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
& a_err='clip & psb_spcnv csr 4')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
|
||||
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='solver build')
|
||||
goto 9999
|
||||
end if
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_jac_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_d_jac_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_jac_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
sm%pa => null()
|
||||
if ((info==0).and.allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_d_jac_smoother_clear_data
|
||||
@@ -1,15 +1,15 @@
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
@@ -21,7 +21,7 @@
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
@@ -33,10 +33,10 @@
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
subroutine mld_d_jac_smoother_clone(sm,smout,info)
|
||||
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_clone
|
||||
|
||||
@@ -59,19 +59,25 @@ subroutine mld_d_jac_smoother_clone(sm,smout,info)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& allocate(mld_d_jac_smoother_type :: smout, stat=info)
|
||||
if (info /= 0) then
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
goto 9999
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
select type(smo => smout)
|
||||
type is (mld_d_jac_smoother_type)
|
||||
smo%nd_nnz_tot = sm%nd_nnz_tot
|
||||
smo%checkres = sm%checkres
|
||||
smo%printres = sm%printres
|
||||
smo%checkiter = sm%checkiter
|
||||
smo%printiter = sm%printiter
|
||||
smo%tol = sm%tol
|
||||
call sm%nd%clone(smo%nd,info)
|
||||
if ((info==psb_success_).and.(allocated(sm%sv))) then
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
smo%pa => sm%pa
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
|
||||
@@ -0,0 +1,101 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! asd on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_jac_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_d_jac_smoother_type), intent(inout) :: sm
|
||||
class(mld_d_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_jac_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(smout)
|
||||
class is(mld_d_jac_smoother_type)
|
||||
|
||||
smout%pa => null()
|
||||
smout%nd_nnz_tot = 0
|
||||
smout%checkres = sm%checkres
|
||||
smout%printres = sm%printres
|
||||
smout%checkiter = sm%checkiter
|
||||
smout%printiter = sm%printiter
|
||||
smout%tol = sm%tol
|
||||
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_d_jac_smoother_clone_settings
|
||||
@@ -59,7 +59,7 @@ subroutine mld_d_jac_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
|
||||
|
||||
if (info == psb_success_) then
|
||||
if ((.not.associated(sm%pa)).and.(sm%nd%is_asb())) then
|
||||
if (sm%nd%is_asb()) then
|
||||
if (present(amold)) then
|
||||
call sm%nd%cscnv(info,&
|
||||
& mold=amold,dupl=psb_dupl_add_)
|
||||
|
||||
@@ -52,22 +52,27 @@ subroutine mld_d_jac_smoother_csetc(sm,what,val,info,idx)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SMOOTHER_STOP')
|
||||
if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
|
||||
sm%checkres = .true.
|
||||
else
|
||||
sm%checkres = .false.
|
||||
end if
|
||||
case('SMOOTHER_TRACE')
|
||||
if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
|
||||
sm%printres = .true.
|
||||
else
|
||||
sm%printres = .false.
|
||||
end if
|
||||
case default
|
||||
call sm%mld_d_base_smoother_type%set(what,val,info,idx=idx)
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SMOOTHER_STOP')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('T','TRUE')
|
||||
sm%checkres = .true.
|
||||
case('F','FALSE')
|
||||
sm%checkres = .false.
|
||||
case default
|
||||
write(0,*) 'Unknown value for smoother_stop : "',psb_toupper(trim(val)),'"'
|
||||
end select
|
||||
case('SMOOTHER_TRACE')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('T','TRUE')
|
||||
sm%printres = .true.
|
||||
case('F','FALSE')
|
||||
sm%printres = .false.
|
||||
case default
|
||||
write(0,*) 'Unknown value for smoother_trace : "',psb_toupper(trim(val)),'"'
|
||||
end select
|
||||
case default
|
||||
call sm%mld_d_base_smoother_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) then
|
||||
|
||||
@@ -35,21 +35,23 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_d_jac_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_jac_smoother, mld_protect_nam => mld_d_jac_smoother_dmp
|
||||
implicit none
|
||||
class(mld_d_jac_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
integer(psb_lpk_), allocatable :: iv(:)
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,7 +61,7 @@ subroutine mld_d_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
|
||||
else
|
||||
prefix_ = "dump_smth_d"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(smoother)) then
|
||||
@@ -67,6 +69,11 @@ subroutine mld_d_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
|
||||
else
|
||||
smoother_ = .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_)
|
||||
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
|
||||
@@ -74,11 +81,17 @@ subroutine mld_d_jac_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solve
|
||||
|
||||
if (smoother_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
|
||||
if (sm%nd%is_asb()) &
|
||||
& call sm%nd%print(fname,head=head)
|
||||
if (global_num_) then
|
||||
iv = desc%get_global_indices(owned=.false.)
|
||||
if (sm%nd%is_asb()) &
|
||||
& call sm%nd%print(fname,head=head,iv=iv)
|
||||
else
|
||||
if (sm%nd%is_asb()) &
|
||||
& call sm%nd%print(fname,head=head)
|
||||
end if
|
||||
end if
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_d_jac_smoother_dmp
|
||||
|
||||
@@ -0,0 +1,175 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_l1_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_diag_solver
|
||||
use mld_d_jac_smoother, mld_protect_name => mld_d_l1_jac_smoother_bld
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(psb_dspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(mld_d_l1_jac_smoother_type), intent(inout) :: sm
|
||||
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
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
|
||||
real(psb_dpk_), allocatable :: arwsum(:)
|
||||
type(psb_dspmat_type) :: tmpa
|
||||
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
|
||||
character(len=20) :: name='d_l1_jac_smoother_bld', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ictxt = desc_a%get_context()
|
||||
call psb_info(ictxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
|
||||
n_row = desc_a%get_local_rows()
|
||||
n_col = desc_a%get_local_cols()
|
||||
nrow_a = a%get_nrows()
|
||||
nztota = a%get_nzeros()
|
||||
|
||||
sm%pa => a
|
||||
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_d_diag_solver_type)
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = nztota
|
||||
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
|
||||
class default
|
||||
if (smsv%is_global()) then
|
||||
! Do not put anything into SM%ND since the solver
|
||||
! is acting globally.
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
else
|
||||
|
||||
call a%csclip(tmpa,info,&
|
||||
& jmax=nrow_a,rscale=.false.,cscale=.false.)
|
||||
|
||||
call a%csclip(sm%nd,info,&
|
||||
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
|
||||
|
||||
arwsum = sm%nd%arwsum(info)
|
||||
|
||||
call combine_dl1(-done,arwsum,sm%nd,info)
|
||||
call combine_dl1(done,arwsum,tmpa,info)
|
||||
|
||||
sm%nd_nnz_tot = sm%nd%get_nzeros()
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
|
||||
call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold)
|
||||
|
||||
if (info == psb_success_) then
|
||||
if (present(amold)) then
|
||||
call sm%nd%cscnv(info,&
|
||||
& mold=amold,dupl=psb_dupl_add_)
|
||||
else
|
||||
call sm%nd%cscnv(info,&
|
||||
& type='csr',dupl=psb_dupl_add_)
|
||||
endif
|
||||
end if
|
||||
end if
|
||||
end select
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='clip & psb_spcnv csr 4')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='solver build')
|
||||
goto 9999
|
||||
end if
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine combine_dl1(alpha,dl1,mat,info)
|
||||
implicit none
|
||||
real(psb_dpk_), intent(in) :: alpha, dl1(:)
|
||||
type(psb_dspmat_type), intent(inout) :: mat
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
!
|
||||
integer(psb_ipk_) :: k, nz, nrm, dp
|
||||
type(psb_d_coo_sparse_mat) :: tcoo
|
||||
|
||||
call mat%mv_to(tcoo)
|
||||
nz = tcoo%get_nzeros()
|
||||
nrm = min(size(dl1),tcoo%get_nrows(),tcoo%get_ncols())
|
||||
!!$ write(0,*) 'Check on combine_dl1: ',nrm, tcoo%get_nrows(),tcoo%get_ncols(), nz
|
||||
call tcoo%ensure_size(nz+nrm)
|
||||
call tcoo%set_dupl(psb_dupl_add_)
|
||||
do k=1,nrm
|
||||
if (dl1(k) /= dzero) then
|
||||
nz = nz + 1
|
||||
tcoo%ia(nz) = k
|
||||
tcoo%ja(nz) = k
|
||||
tcoo%val(nz) = alpha*dl1(k)
|
||||
end if
|
||||
end do
|
||||
call tcoo%set_nzeros(nz)
|
||||
call tcoo%fix(info)
|
||||
call mat%mv_from(tcoo)
|
||||
end subroutine combine_dl1
|
||||
|
||||
|
||||
end subroutine mld_d_l1_jac_smoother_bld
|
||||
@@ -0,0 +1,93 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_l1_jac_smoother_clone(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_jac_smoother, mld_protect_name => mld_d_l1_jac_smoother_clone
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_d_l1_jac_smoother_type), intent(inout) :: sm
|
||||
class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (allocated(smout)) then
|
||||
call smout%free(info)
|
||||
if (info == psb_success_) deallocate(smout, stat=info)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& allocate(mld_d_l1_jac_smoother_type :: smout, stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
select type(smo => smout)
|
||||
type is (mld_d_l1_jac_smoother_type)
|
||||
smo%nd_nnz_tot = sm%nd_nnz_tot
|
||||
smo%checkres = sm%checkres
|
||||
smo%printres = sm%printres
|
||||
smo%checkiter = sm%checkiter
|
||||
smo%printiter = sm%printiter
|
||||
smo%tol = sm%tol
|
||||
call sm%nd%clone(smo%nd,info)
|
||||
if ((info==psb_success_).and.(allocated(sm%sv))) then
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_d_l1_jac_smoother_clone
|
||||
@@ -0,0 +1,103 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_d_l1_jac_smoother_descr(sm,info,iout,coarse)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_d_diag_solver
|
||||
use mld_d_jac_smoother, mld_protect_name => mld_d_l1_jac_smoother_descr
|
||||
use mld_d_diag_solver
|
||||
use mld_d_gs_solver
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_d_l1_jac_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='mld_d_l1_jac_smoother_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
logical :: coarse_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(coarse)) then
|
||||
coarse_ = coarse
|
||||
else
|
||||
coarse_ = .false.
|
||||
end if
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
if (.not.coarse_) then
|
||||
if (allocated(sm%sv)) then
|
||||
select type(smv=>sm%sv)
|
||||
class is (mld_d_diag_solver_type)
|
||||
write(iout_,*) ' Point Jacobi '
|
||||
write(iout_,*) ' Local diagonal:'
|
||||
call smv%descr(info,iout_,coarse=coarse)
|
||||
class is (mld_d_bwgs_solver_type)
|
||||
write(iout_,*) ' L1-Hybrid Backward Gauss-Seidel '
|
||||
class is (mld_d_gs_solver_type)
|
||||
write(iout_,*) ' L1-Hybrid Forward Gauss-Seidel '
|
||||
class default
|
||||
write(iout_,*) ' L1-Block Jacobi '
|
||||
write(iout_,*) ' Local solver details:'
|
||||
call smv%descr(info,iout_,coarse=coarse)
|
||||
end select
|
||||
|
||||
else
|
||||
write(iout_,*) ' L1-Block Jacobi '
|
||||
end if
|
||||
else
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%descr(info,iout_,coarse=coarse)
|
||||
end if
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine mld_d_l1_jac_smoother_descr
|
||||
@@ -105,116 +105,218 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
if (.false.) then
|
||||
if (sweeps > 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%pa,y,sone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,ww,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%pa,ty,sone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(sone,x,szero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%pa,ty,sone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
end do
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
|
||||
endif
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,sm%desc_data,info)
|
||||
call psb_geasb(ty,sm%desc_data,info)
|
||||
call psb_geasb(ww,sm%desc_data,info)
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
end if
|
||||
|
||||
|
||||
if (.not.(4*isz <= size(work))) then
|
||||
deallocate(aux,stat=info)
|
||||
endif
|
||||
|
||||
@@ -107,89 +107,140 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
if (.true.) then
|
||||
|
||||
if (sweeps > 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
end if
|
||||
|
||||
!
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%pa,y,sone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,ww,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%pa,ty,sone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+D^(-1)*(X-A*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(sone,x,szero,ww,desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%pa,ty,sone,ww,desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_restr(ww,trans_,aux,info)
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
|
||||
else
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.(sweeps == 1).and.(sm%novr==0)) then
|
||||
!
|
||||
! Shortcut: in this case there is nothing else to be done.
|
||||
!
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
@@ -197,47 +248,125 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
else if (sweeps >= 0) then
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of an AS solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 3) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
! This is tricky. This smoother has a descriptor sm%desc_data
|
||||
! for an index space potentially different from
|
||||
! that of desc_data. Hence the size of the work vectors
|
||||
! could be wrong. We need to check and reallocate as needed.
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
|
||||
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
if (do_realloc_wv) then
|
||||
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
|
||||
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
|
||||
end if
|
||||
|
||||
endif
|
||||
associate(tx => wv(1), ty => wv(2), ww => wv(3))
|
||||
|
||||
! Need to zero tx because of the apply_restr call.
|
||||
call tx%zero()
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
|
||||
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
|
||||
& work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
|
||||
|
||||
end do
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!
|
||||
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
|
||||
!
|
||||
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
end associate
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
goto 9999
|
||||
|
||||
endif
|
||||
end if
|
||||
|
||||
if (.not.(4*isz <= size(work))) then
|
||||
deallocate(aux,stat=info)
|
||||
|
||||
@@ -66,7 +66,7 @@ subroutine mld_s_as_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
|
||||
sm%pa => a
|
||||
novr = sm%novr
|
||||
if (novr < 0) then
|
||||
info=psb_err_invalid_ovr_num_
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_as_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_as_smoother, mld_protect_name => mld_s_as_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_s_as_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_as_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call sm%desc_data%free(info)
|
||||
if ((info==0).and.allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_s_as_smoother_clear_data
|
||||
@@ -77,6 +77,7 @@ subroutine mld_s_as_smoother_clone(sm,smout,info)
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
smo%pa => sm%pa
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
|
||||
@@ -0,0 +1,95 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! asd on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_as_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_as_smoother, mld_protect_name => mld_s_as_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_s_as_smoother_type), intent(inout) :: sm
|
||||
class(mld_s_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_as_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(smout)
|
||||
class is(mld_s_as_smoother_type)
|
||||
smout%novr = sm%novr
|
||||
smout%restr = sm%restr
|
||||
smout%prol = sm%prol
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_s_as_smoother_clone_settings
|
||||
@@ -35,21 +35,22 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_s_as_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_dmp
|
||||
implicit none
|
||||
class(mld_s_as_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,7 +60,7 @@ subroutine mld_s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
else
|
||||
prefix_ = "dump_smth_s"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(smoother)) then
|
||||
@@ -67,11 +68,18 @@ subroutine mld_s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
else
|
||||
smoother_ = .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_)
|
||||
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
|
||||
lname = lname + 5
|
||||
|
||||
if (global_num_) then
|
||||
write(0,*) iam,' Warning: no global num with AS smoothers dump'
|
||||
end if
|
||||
if (smoother_) then
|
||||
write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx'
|
||||
if (sm%nd%is_asb()) &
|
||||
@@ -79,6 +87,6 @@ subroutine mld_s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver
|
||||
end if
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_s_as_smoother_dmp
|
||||
|
||||
@@ -61,6 +61,7 @@ subroutine mld_s_as_smoother_free(sm,info)
|
||||
end if
|
||||
end if
|
||||
call sm%nd%free()
|
||||
sm%pa => null()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
@@ -0,0 +1,67 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_base_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_s_base_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_base_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_s_base_smoother_clear_data
|
||||
@@ -45,7 +45,7 @@ subroutine mld_s_base_smoother_clone(sm,smout,info)
|
||||
class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_smoother_clone'
|
||||
character(len=20) :: name='s_base_smoother_clone'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
@@ -0,0 +1,89 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_base_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_s_base_smoother_type), intent(inout) :: sm
|
||||
class(mld_s_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_base_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info=psb_success_
|
||||
if (same_type_as(sm,smout)) then
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_s_base_smoother_clone_settings
|
||||
@@ -48,7 +48,7 @@ subroutine mld_s_base_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_base_smoother_cnv'
|
||||
character(len=20) :: name='s_base_smoother_cnv'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
@@ -35,21 +35,22 @@
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver)
|
||||
subroutine mld_s_base_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_dmp
|
||||
implicit none
|
||||
class(mld_s_base_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(in) :: ictxt,level
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
integer(psb_ipk_) :: icontxt,iam, np
|
||||
integer(psb_ipk_) :: ictxt,iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
logical :: smoother_
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
@@ -59,9 +60,14 @@ subroutine mld_s_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
|
||||
else
|
||||
prefix_ = "dump_smth_s"
|
||||
end if
|
||||
|
||||
ictxt = desc%get_context()
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
if (present(smoother)) then
|
||||
smoother_ = smoother
|
||||
else
|
||||
@@ -74,6 +80,6 @@ subroutine mld_s_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solv
|
||||
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(ictxt,level,info,solver=solver,prefix=prefix)
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine mld_s_base_smoother_dmp
|
||||
|
||||
@@ -65,7 +65,7 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
ictxt = desc_data%get_context()
|
||||
call psb_info(ictxt,me,np)
|
||||
|
||||
|
||||
|
||||
if (present(init)) then
|
||||
init_ = psb_toupper(init)
|
||||
else
|
||||
@@ -102,146 +102,63 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
|
||||
! if .not.sv%is_iterative, there's no need to pass init
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,&
|
||||
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
|
||||
if (sweeps > 0) then
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
if (associated(sm%pa)) then
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! This means we are dealing with a pure Jacobi smoother/solver.
|
||||
! Compute Y(j+1) = Y(j)+ M^(-1)*(X-A*Y(j)),
|
||||
!
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of a block-Jacobi solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
call psb_geasb(tx,desc_data,info)
|
||||
call psb_geasb(ty,desc_data,info)
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one AXPBY and one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z')
|
||||
call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
end do
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
|
||||
deallocate(tx,ty,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
@@ -250,6 +167,12 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,&
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
info = psb_err_iarg_neg_
|
||||
|
||||
@@ -49,7 +49,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
type(psb_s_vect_type),intent(inout) :: y
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_s_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
@@ -108,190 +108,90 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
end if
|
||||
endif
|
||||
|
||||
if(sm%checkres) then
|
||||
call psb_geall(r,desc_data,info)
|
||||
call psb_geasb(r,desc_data,info)
|
||||
resdenum = psb_genrm2(x,desc_data,info)
|
||||
end if
|
||||
if (sweeps > 0) then
|
||||
|
||||
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
|
||||
! if .not.sv%is_iterative, there's no need to pass init
|
||||
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
if(sm%checkres) then
|
||||
call psb_geall(r,desc_data,info)
|
||||
call psb_geasb(r,desc_data,info)
|
||||
resdenum = psb_genrm2(x,desc_data,info)
|
||||
end if
|
||||
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_internal_error_,&
|
||||
& name,a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
goto 9999
|
||||
endif
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
select case (init_)
|
||||
case('Z')
|
||||
|
||||
else if (sweeps >= 0) then
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_s_diag_solver_type)
|
||||
!
|
||||
! This means we are dealing with a pure Jacobi smoother/solver.
|
||||
!
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
select case (init_)
|
||||
case('Z')
|
||||
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
|
||||
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(sone,x,szero,r,r,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if ( res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
! where is the diagonal and A the matrix.
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(sone,x,szero,r,r,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if ( res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
|
||||
end associate
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
class default
|
||||
!
|
||||
!
|
||||
! Apply multiple sweeps of a block-Jacobi solver
|
||||
! to compute an approximate solution of a linear system.
|
||||
!
|
||||
!
|
||||
if (size(wv) < 2) then
|
||||
info = psb_err_internal_error_
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
associate(tx => wv(1), ty => wv(2))
|
||||
|
||||
!
|
||||
! Unroll the first iteration and fold it inside SELECT CASE
|
||||
! this will save one AXPBY and one SPMM when INIT=Z, and will be
|
||||
! significant when sweeps=1 (a common case)
|
||||
!
|
||||
select case (init_)
|
||||
case('Z')
|
||||
end associate
|
||||
|
||||
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
|
||||
case('Y')
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case('U')
|
||||
if (.not.present(initu)) then
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='missing initu to smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
case default
|
||||
call psb_errpush(psb_err_internal_error_,name,&
|
||||
& a_err='wrong init to smoother_apply')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
do i=1, sweeps-1
|
||||
!
|
||||
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
! block diagonal part and the remaining part of the local matrix
|
||||
! and Y(j) is the approximate solution at sweep j.
|
||||
!
|
||||
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
|
||||
if (info /= psb_success_) exit
|
||||
|
||||
if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
call psb_geaxpby(sone,x,szero,r,r,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info)
|
||||
res = psb_genrm2(r,desc_data,info)
|
||||
if( sm%printres ) then
|
||||
call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
end if
|
||||
if (res < sm%tol*resdenum ) then
|
||||
if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) &
|
||||
& call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
exit
|
||||
end if
|
||||
end if
|
||||
|
||||
end do
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='subsolve with Jacobi sweeps > 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
end associate
|
||||
end select
|
||||
else if (sweeps == 0) then
|
||||
!
|
||||
! 0 sweeps of smoother is the identity operator
|
||||
!
|
||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||
|
||||
else
|
||||
|
||||
|
||||
@@ -51,9 +51,8 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
! Local variables
|
||||
type(psb_sspmat_type) :: tmpa
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
|
||||
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
|
||||
type(psb_s_coo_sparse_mat) :: tmpcoo
|
||||
integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level
|
||||
character(len=20) :: name='s_jac_smoother_bld', ch_err
|
||||
|
||||
@@ -72,19 +71,23 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
nrow_a = a%get_nrows()
|
||||
nztota = a%get_nzeros()
|
||||
|
||||
if( sm%checkres ) sm%pa => a
|
||||
sm%pa => a
|
||||
|
||||
select type (smsv => sm%sv)
|
||||
class is (mld_s_diag_solver_type)
|
||||
call sm%nd%free()
|
||||
sm%pa => a
|
||||
sm%nd_nnz_tot = nztota
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
|
||||
class default
|
||||
if (smsv%is_global()) then
|
||||
! Do not put anything into SM%ND since the solver
|
||||
! is acting globally.
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
else
|
||||
call a%csclip(sm%nd,info,&
|
||||
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
|
||||
@@ -98,6 +101,10 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
endif
|
||||
end if
|
||||
sm%nd_nnz_tot = sm%nd%get_nzeros()
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
call a%csclip(tmpa,info,&
|
||||
& jmax=nrow_a,rscale=.false.,cscale=.false.)
|
||||
call sm%sv%build(tmpa,desc_a,info,amold=amold,vmold=vmold)
|
||||
end if
|
||||
end select
|
||||
if (info /= psb_success_) then
|
||||
@@ -105,15 +112,7 @@ subroutine mld_s_jac_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
& a_err='clip & psb_spcnv csr 4')
|
||||
goto 9999
|
||||
end if
|
||||
call psb_sum(ictxt,sm%nd_nnz_tot)
|
||||
|
||||
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='solver build')
|
||||
goto 9999
|
||||
end if
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_jac_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_s_jac_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_jac_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
call sm%nd%free()
|
||||
sm%nd_nnz_tot = 0
|
||||
sm%pa => null()
|
||||
if ((info==0).and.allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_s_jac_smoother_clear_data
|
||||
@@ -1,15 +1,15 @@
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
@@ -21,7 +21,7 @@
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
@@ -33,10 +33,10 @@
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
subroutine mld_s_jac_smoother_clone(sm,smout,info)
|
||||
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_clone
|
||||
|
||||
@@ -59,19 +59,25 @@ subroutine mld_s_jac_smoother_clone(sm,smout,info)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& allocate(mld_s_jac_smoother_type :: smout, stat=info)
|
||||
if (info /= 0) then
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
goto 9999
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
select type(smo => smout)
|
||||
type is (mld_s_jac_smoother_type)
|
||||
smo%nd_nnz_tot = sm%nd_nnz_tot
|
||||
smo%checkres = sm%checkres
|
||||
smo%printres = sm%printres
|
||||
smo%checkiter = sm%checkiter
|
||||
smo%printiter = sm%printiter
|
||||
smo%tol = sm%tol
|
||||
call sm%nd%clone(smo%nd,info)
|
||||
if ((info==psb_success_).and.(allocated(sm%sv))) then
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
smo%pa => sm%pa
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
|
||||
@@ -0,0 +1,101 @@
|
||||
!
|
||||
!
|
||||
! MLD2P4 version 2.2
|
||||
! MultiLevel Domain Decomposition Parallel Preconditioners Package
|
||||
! asd on PSBLAS (Parallel Sparse BLAS version 3.5)
|
||||
!
|
||||
! (C) Copyright 2008-2018
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the MLD2P4 group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine mld_s_jac_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_s_jac_smoother_type), intent(inout) :: sm
|
||||
class(mld_s_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_jac_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(smout)
|
||||
class is(mld_s_jac_smoother_type)
|
||||
|
||||
smout%pa => null()
|
||||
smout%nd_nnz_tot = 0
|
||||
smout%checkres = sm%checkres
|
||||
smout%printres = sm%printres
|
||||
smout%checkiter = sm%checkiter
|
||||
smout%printiter = sm%printiter
|
||||
smout%tol = sm%tol
|
||||
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine mld_s_jac_smoother_clone_settings
|
||||
@@ -59,7 +59,7 @@ subroutine mld_s_jac_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
|
||||
|
||||
if (info == psb_success_) then
|
||||
if ((.not.associated(sm%pa)).and.(sm%nd%is_asb())) then
|
||||
if (sm%nd%is_asb()) then
|
||||
if (present(amold)) then
|
||||
call sm%nd%cscnv(info,&
|
||||
& mold=amold,dupl=psb_dupl_add_)
|
||||
|
||||
@@ -52,22 +52,27 @@ subroutine mld_s_jac_smoother_csetc(sm,what,val,info,idx)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SMOOTHER_STOP')
|
||||
if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
|
||||
sm%checkres = .true.
|
||||
else
|
||||
sm%checkres = .false.
|
||||
end if
|
||||
case('SMOOTHER_TRACE')
|
||||
if((psb_toupper(trim(val)) == 'T').or.(psb_toupper(trim(val)) == 'TRUE')) then
|
||||
sm%printres = .true.
|
||||
else
|
||||
sm%printres = .false.
|
||||
end if
|
||||
case default
|
||||
call sm%mld_s_base_smoother_type%set(what,val,info,idx=idx)
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('SMOOTHER_STOP')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('T','TRUE')
|
||||
sm%checkres = .true.
|
||||
case('F','FALSE')
|
||||
sm%checkres = .false.
|
||||
case default
|
||||
write(0,*) 'Unknown value for smoother_stop : "',psb_toupper(trim(val)),'"'
|
||||
end select
|
||||
case('SMOOTHER_TRACE')
|
||||
select case(psb_toupper(trim(val)))
|
||||
case('T','TRUE')
|
||||
sm%printres = .true.
|
||||
case('F','FALSE')
|
||||
sm%printres = .false.
|
||||
case default
|
||||
write(0,*) 'Unknown value for smoother_trace : "',psb_toupper(trim(val)),'"'
|
||||
end select
|
||||
case default
|
||||
call sm%mld_s_base_smoother_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) then
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user