fdurastante
/
amg4psblas
mirror of https://github.com/sfilippone/amg4psblas.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

First working version

Browse Source
remap-coarse
sfilippone 6 days ago
parent 42313bb843
commit 23f84ce236
8 changed files with 110 additions and 155 deletions
Show Stats Download Patch File Download Diff File

8
amgprec/amg_d_onelev_mod.f90
Unescape Escape View File

@ -762,7 +762,7 @@ contains
info = psb_success_ info = psb_success_
nwv = lv%get_wrksz() nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() !!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb()
if (info == 0) then if (info == 0) then
if (lv%remap_data%desc_ac_pre_remap%is_asb()) then if (lv%remap_data%desc_ac_pre_remap%is_asb()) then
! !
@ -810,12 +810,12 @@ contains
info = psb_success_ info = psb_success_
call wk%free(info) call wk%free(info)
write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& !!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',&
& present(desc2),desc%is_valid() !!$ & present(desc2),desc%is_valid()
allocate(wk%wv(nwv),stat=info) allocate(wk%wv(nwv),stat=info)
if (present(desc2).and.(desc%is_valid())) then if (present(desc2).and.(desc%is_valid())) then
write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() !!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb()
if (desc2%get_local_cols()>desc%get_local_cols()) then if (desc2%get_local_cols()>desc%get_local_cols()) then
call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold)
else else

19
amgprec/amg_d_prec_type.f90
Unescape Escape View File

@ -437,11 +437,11 @@ contains
class(amg_dprec_type), intent(in) :: prec class(amg_dprec_type), intent(in) :: prec
integer(psb_ipk_) :: val integer(psb_ipk_) :: val
val = 0 val = 0
if (allocated(prec%precv)) then !!$ if (allocated(prec%precv)) then
val = size(prec%precv) !!$ val = size(prec%precv)
end if !!$ end if
val = prec%nlevs val = prec%nlevs
write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv) !!$ write(0,*) ' NLEVS: ',prec%nlevs, val,size(prec%precv)
end function amg_d_get_nlevs end function amg_d_get_nlevs
@ -532,9 +532,9 @@ contains
if (num >= dzero) then if (num >= dzero) then
den = num den = num
nl = prec%get_nlevs() nl = prec%get_nlevs()
write(0,*) 'Inside cmp_compl ',nl,size(prec%precv) !!$ write(0,*) 'Inside cmp_compl ',nl,size(prec%precv)
do il=2, nl do il=2, nl
write(0,*) ' ',il,associated(prec%precv(il)%base_a) !!$ write(0,*) ' ',il,associated(prec%precv(il)%base_a)
num = num + max(0,prec%precv(il)%base_a%get_nzeros()) num = num + max(0,prec%precv(il)%base_a%get_nzeros())
end do end do
end if end if
@ -627,9 +627,7 @@ contains
end subroutine amg_dprecfree end subroutine amg_dprecfree
subroutine amg_d_prec_free(prec,info) subroutine amg_d_prec_free(prec,info)
implicit none implicit none
! Arguments ! Arguments
class(amg_dprec_type), intent(inout) :: prec class(amg_dprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -661,9 +659,7 @@ contains
end subroutine amg_d_prec_free end subroutine amg_d_prec_free
subroutine amg_d_smoothers_free(prec,info) subroutine amg_d_smoothers_free(prec,info)
implicit none implicit none
! Arguments ! Arguments
class(amg_dprec_type), intent(inout) :: prec class(amg_dprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -927,7 +923,6 @@ contains
end subroutine amg_d_clone end subroutine amg_d_clone
subroutine amg_d_inner_clone(prec,precout,info) subroutine amg_d_inner_clone(prec,precout,info)
implicit none implicit none
class(amg_dprec_type), intent(inout) :: prec class(amg_dprec_type), intent(inout) :: prec
class(psb_dprec_type), target, intent(inout) :: precout class(psb_dprec_type), target, intent(inout) :: precout
@ -1012,7 +1007,6 @@ contains
subroutine amg_d_allocate_wrk(prec,info,vmold,desc) subroutine amg_d_allocate_wrk(prec,info,vmold,desc)
use psb_base_mod use psb_base_mod
implicit none implicit none
! Arguments ! Arguments
class(amg_dprec_type), intent(inout) :: prec class(amg_dprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1090,7 +1084,6 @@ contains
function amg_d_is_allocated_wrk(prec) result(res) function amg_d_is_allocated_wrk(prec) result(res)
use psb_base_mod use psb_base_mod
implicit none implicit none
! Arguments ! Arguments
class(amg_dprec_type), intent(in) :: prec class(amg_dprec_type), intent(in) :: prec
logical :: res logical :: res

178
amgprec/impl/amg_d_hierarchy_bld.F90
Unescape Escape View File

@ -243,7 +243,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
goto 9999 goto 9999
end if end if
! !
! First set desired number of levels ! First set desired number of levels if different from default.
! !
if (iszv /= nplevs) then if (iszv /= nplevs) then
allocate(tprecv(nplevs),stat=info) allocate(tprecv(nplevs),stat=info)
@ -292,6 +292,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
call prec%set_nlevs(nplevs) call prec%set_nlevs(nplevs)
iszv = prec%get_nlevs() iszv = prec%get_nlevs()
end if end if
! !
! Finest level first; create a GEN_BLOCK ! Finest level first; create a GEN_BLOCK
! copy of the descriptor. ! copy of the descriptor.
@ -305,6 +306,10 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info) call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info)
prec%precv(1)%base_desc => prec%precv(1)%desc_ac prec%precv(1)%base_desc => prec%precv(1)%desc_ac
!
! Main build loop
!
newsz = 0 newsz = 0
stop_hierarchy_loop = .false. stop_hierarchy_loop = .false.
array_build_loop: do i=2, iszv array_build_loop: do i=2, iszv
@ -313,9 +318,12 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
! on all processes. ! on all processes.
! !
call psb_bcast(ctxt,prec%precv(i)%parms) call psb_bcast(ctxt,prec%precv(i)%parms)
!
! Get current context: might have performed remapping
!
lctxt = prec%precv(i-1)%base_desc%get_ctxt() lctxt = prec%precv(i-1)%base_desc%get_ctxt()
call psb_info(lctxt,lme,lnp) call psb_info(lctxt,lme,lnp)
write(0,*) 'Check at level',i,lme,lnp !!$ write(0,*) 'Check at level',i,lme,lnp
! !
! Sanity checks on the parameters ! Sanity checks on the parameters
! !
@ -331,8 +339,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i & 'Calling mlprcbld at level ',i
! !
! Build the mapping between levels i-1 and i and the matrix ! Build the tentative mapping between levels i-1 and i
! at level i ! and the matrixat level i
! !
if (do_timings) call psb_tic(idx_bldtp) if (do_timings) call psb_tic(idx_bldtp)
if (info == psb_success_)& if (info == psb_success_)&
@ -355,22 +363,25 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
! !
call op_prol%clone(prec%precv(i)%tprol,info) call op_prol%clone(prec%precv(i)%tprol,info)
! !
! Check for early termination of aggregation loop. ! Check for early termination of aggregation loop.
! !
if (i == 2) then if (i == 2) then
call amg_hierarchy_bld_newsz(i,iszv,& call amg_d_hierarchy_bld_cmp_newsz(i,iszv,&
& desc_a%get_global_rows(),nlaggr,mnaggratio,sizeratio,newsz) & desc_a%get_global_rows(),&
& nlaggr,casize,mnaggratio,sizeratio,newsz)
else else
call amg_hierarchy_bld_newsz(i,iszv,& call amg_d_hierarchy_bld_cmp_newsz(i,iszv,&
& sum(prec%precv(i-1)%linmap%naggr),nlaggr,mnaggratio,sizeratio,newsz) & sum(prec%precv(i-1)%linmap%naggr),&
& nlaggr,casize,mnaggratio,sizeratio,newsz)
end if end if
prec%precv(i)%szratio = sizeratio prec%precv(i)%szratio = sizeratio
call psb_bcast(ctxt,newsz) call psb_bcast(ctxt,newsz)
!
! Handle reallocation, if needed, and then mat_asb to polish off the ! Handle reallocation, if needed, and then mat_asb to polish off the
! construction ! construction
!
if (newsz > 0) then if (newsz > 0) then
! !
! This is awkward, we are saving the aggregation parms, for the sake ! This is awkward, we are saving the aggregation parms, for the sake
@ -405,8 +416,6 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
goto 9999 goto 9999
endif endif
!!$ write(0,*) ' Early exit of array_build_loop',i,iszv,info,& !!$ write(0,*) ' Early exit of array_build_loop',i,iszv,info,&
!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
!!$ exit array_build_loop
level = newsz level = newsz
stop_hierarchy_loop = .true. stop_hierarchy_loop = .true.
else else
@ -420,27 +429,27 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
! !
! Do we want to remap onto a smaller subset of processes? ! Do we want to remap onto a smaller subset of processes?
! Will need a more sophisticated policy
! !
block
if (amg_policy_do_remap(level,sum(nlaggr))) then type(psb_ctxt_type) :: lctxt
block integer(psb_ipk_) :: lme,lnp
type(psb_ctxt_type) :: lctxt lctxt = prec%precv(level)%desc_ac%get_ctxt()
integer(psb_ipk_) :: lme,lnp call psb_info(lctxt,lme,lnp)
lctxt = prec%precv(level)%desc_ac%get_ctxt() if (amg_d_policy_do_remap(lctxt,level,sum(nlaggr))) then
call psb_info(lctxt,lme,lnp) !!$ write(0,*) ' Context on remapping ',lme,lnp
write(0,*) ' Context on remapping ',lme,lnp
if ((lme >=0).and.(lnp>=2)) then if ((lme >=0).and.(lnp>=2)) then
associate(lv=>prec%precv(level), rmp => prec%precv(level)%remap_data) associate(lv=>prec%precv(level), rmp => prec%precv(level)%remap_data)
call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info)
call lv%ac%clone(rmp%ac_pre_remap,info) call lv%ac%clone(rmp%ac_pre_remap,info)
write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),& !!$ write(0,*) 'During first remapping desc_ac:',lv%desc_ac%is_asb(),&
& rmp%desc_ac_pre_remap%is_asb() !!$ & rmp%desc_ac_pre_remap%is_asb()
write(0,*) ' First Doing remapping ',lnp, lnp/2 !!$ write(0,*) ' First Doing remapping ',lnp, lnp/2
call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,&
& rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info)
!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& !!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',&
!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) !!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr)
write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr) !!$ write(0,*) 'First Assignment ',size(lv%linmap%naggr),size(rmp%naggr)
lv%linmap%naggr(:) = rmp%naggr(:) lv%linmap%naggr(:) = rmp%naggr(:)
lv%linmap%p_desc_V => rmp%desc_ac_pre_remap lv%linmap%p_desc_V => rmp%desc_ac_pre_remap
lv%base_a => lv%ac lv%base_a => lv%ac
@ -452,16 +461,16 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
call psb_info(ct,meu,npu) call psb_info(ct,meu,npu)
ct = lv%linmap%p_desc_V%get_ctxt() ct = lv%linmap%p_desc_V%get_ctxt()
call psb_info(ct,mev,npv) call psb_info(ct,mev,npv)
write(0,*) 'First Check on out remapping ',i,& !!$ write(0,*) 'First Check on out remapping ',i,&
& rmp%desc_ac_pre_remap%is_asb(),& !!$ & rmp%desc_ac_pre_remap%is_asb(),&
& ':',meu,npu,mev,npv !!$ & ':',meu,npu,mev,npv
end block end block
end associate end associate
end if end if
end block !!$ write(0,*) 'Second Check on out remapping ',level,&
write(0,*) 'Second Check on out remapping ',level,& !!$ & prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb(), newsz
& prec%precv(level)%remap_data%desc_ac_pre_remap%is_asb() end if
end if end block
if (info /= psb_success_) then if (info /= psb_success_) then
write(ch_err,'(a,i7)') 'Mat asb fail @ level ',i write(ch_err,'(a,i7)') 'Mat asb fail @ level ',i
@ -476,82 +485,31 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
end if end if
end do array_build_loop end do array_build_loop
write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal() !!$ write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal()
if (newsz>0) then if (newsz>0) then
do i=2,newsz !!$ do i=2,newsz
write(0,*) me,'Newsz Out of array_build_loop ',i,':',& !!$ write(0,*) me,'Newsz Out of array_build_loop ',i,':',&
& prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() !!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
end do !!$ end do
write(0,*) 'Calling set_nlevs ',newsz !!$ write(0,*) 'Calling set_nlevs ',newsz
call prec%set_nlevs(newsz) call prec%set_nlevs(newsz)
else else
do i=2, iszv !!$ do i=2, iszv
write(0,*) me,'Out of array_build_loop ',i,':',& !!$ write(0,*) me,'Out of array_build_loop ',i,':',&
& prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() !!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
end do !!$ end do
end if end if
iszv = prec%get_nlevs() iszv = prec%get_nlevs()
call psb_barrier(ctxt) call psb_barrier(ctxt)
if (.false.) then
if (newsz > 0) then
!
! We exited early from the build loop, need to fix
! the size.
!
allocate(tprecv(newsz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='prec reallocation')
goto 9999
endif
do i=1,newsz
call prec%precv(i)%move_alloc(tprecv(i),info)
end do
do i=newsz+1, iszv
call prec%precv(i)%free(info)
end do
call move_alloc(tprecv,prec%precv)
! Ignore errors from transfer
info = psb_success_
!
! Restart
iszv = newsz
! Fix the pointers, but the level 1 should
! be treated differently
if (.not.associated(prec%precv(1)%base_a,a)) then
prec%precv(1)%base_a => prec%precv(1)%ac
end if
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
! This is needed when the linmap object has been built
! reusing the base_desc descriptor through a pointer.
! With PSBLAS 4 we will have a better solution
if (associated(prec%precv(i)%linmap%p_desc_U)) &
& prec%precv(i)%linmap%p_desc_U => prec%precv(i-1)%base_desc
if (associated(prec%precv(i)%linmap%p_desc_V))&
& prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc
end do
end if
else
if (.not.associated(prec%precv(1)%base_a,a)) then
prec%precv(1)%base_a => prec%precv(1)%ac
end if
if (.not.associated(prec%precv(1)%base_desc,desc_a)) then
prec%precv(1)%base_desc => prec%precv(1)%desc_ac
end if
end if
write(0,*) ' Done reallocating precv',iszv,newsz,info
do i=2, iszv !!$ write(0,*) ' Done reallocating precv',iszv,newsz,info
write(0,*) me,'At end of hierarchy_bld level',i,':',& !!$
& prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() !!$ do i=2, iszv
end do !!$ write(0,*) me,'At end of hierarchy_bld level',i,':',&
!!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
!!$ end do
call psb_barrier(ctxt) call psb_barrier(ctxt)
@ -562,8 +520,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat)
endif endif
iszv = prec%get_nlevs() iszv = prec%get_nlevs()
write(0,*) 'Going for cmp_complexity ',& !!$ write(0,*) 'Going for cmp_complexity ',&
& allocated(prec%precv),iszv,size(prec%precv) !!$ & allocated(prec%precv),iszv,size(prec%precv)
call prec%cmp_complexity() call prec%cmp_complexity()
call prec%cmp_avg_cr() call prec%cmp_avg_cr()
@ -704,34 +662,37 @@ contains
end subroutine restore_smoothers end subroutine restore_smoothers
#endif #endif
function amg_policy_do_remap(level,aggsize) result(res) function amg_d_policy_do_remap(ctxt,level,aggsize) result(res)
logical :: res logical :: res
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: level integer(psb_ipk_) :: level
integer(psb_lpk_) :: aggsize integer(psb_lpk_) :: aggsize
res = amg_get_do_remap().and.(level>=2) res = amg_get_do_remap().and.(level>=2)
!!$ res = .false. !!$ res = .false.
end function amg_policy_do_remap end function amg_d_policy_do_remap
subroutine amg_hierarchy_bld_newsz(level,iszv,prevsize,& subroutine amg_d_hierarchy_bld_cmp_newsz(level,iszv,prevsize,&
& nlaggr,mnratio,sizeratio,newsz) & nlaggr,casize,mnratio,sizeratio,newsz)
implicit none implicit none
integer(psb_ipk_) :: level,iszv,newsz integer(psb_ipk_) :: level,iszv,newsz
integer(psb_lpk_) :: nlaggr(:) integer(psb_lpk_) :: nlaggr(:)
integer(psb_lpk_) :: prevsize integer(psb_lpk_) :: prevsize, casize
real(psb_dpk_) :: mnratio, sizeratio real(psb_dpk_) :: mnratio, sizeratio
! ============================== ! ==============================
integer(psb_lpk_) :: iaggsize, casize integer(psb_lpk_) :: iaggsize
newsz = 0 newsz = 0
iaggsize = sum(nlaggr) iaggsize = sum(nlaggr)
sizeratio = prevsize sizeratio = prevsize
sizeratio = sizeratio/iaggsize sizeratio = sizeratio/iaggsize
!!$ write(0,*) 'From cmp_newsz: ',iaggsize,casize,&
!!$ & sizeratio,mnratio, level
if (iaggsize <= casize) newsz = level if (iaggsize <= casize) newsz = level
if (level == iszv) newsz = level if (level == iszv) newsz = level
if (level>2) then if (level>2) then
if (sizeratio < mnaggratio) then if (sizeratio < mnratio) then
if (sizeratio > 1) then if (sizeratio > 1) then
newsz = level newsz = level
else else
@ -742,6 +703,7 @@ contains
end if end if
end if end if
end if end if
end subroutine amg_hierarchy_bld_newsz !!$ write(0,*) 'At end of cmp_newsz ',newsz
end subroutine amg_d_hierarchy_bld_cmp_newsz
end subroutine amg_d_hierarchy_bld end subroutine amg_d_hierarchy_bld

3
amgprec/impl/amg_dfile_prec_descr.f90
Unescape Escape View File

@ -130,8 +130,6 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
! !
if (me == root_) then if (me == root_) then
nlev = prec%get_nlevs() nlev = prec%get_nlevs()
write(0,*) 'From file_prec_descr: nlev ',nlev
flush(0)
do ilev = 1, nlev do ilev = 1, nlev
if (.not.allocated(prec%precv(ilev)%sm)) then if (.not.allocated(prec%precv(ilev)%sm)) then
info = 3111 info = 3111
@ -143,6 +141,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
write(iout_,*) write(iout_,*)
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description' write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner description'
write(iout_,*) 'At level :',1,' we have ',np,' processes'
if (nlev == 1) then if (nlev == 1) then
! !

8
amgprec/impl/amg_dmlprec_aply.f90
Unescape Escape View File

@ -605,7 +605,7 @@ contains
if(debug_level > 1) then if(debug_level > 1) then
write(debug_unit,*) me,' inner_mult at level ',level write(debug_unit,*) me,' inner_mult at level ',level
end if end if
write(debug_unit,*) me,' inner_mult at level (1):',level,np !!$ write(debug_unit,*) me,' inner_mult at level (1):',level,np
sweeps_post = p%precv(level)%parms%sweeps_post sweeps_post = p%precv(level)%parms%sweeps_post
sweeps_pre = p%precv(level)%parms%sweeps_pre sweeps_pre = p%precv(level)%parms%sweeps_pre
pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N'))
@ -615,8 +615,8 @@ contains
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv) & wv => p%precv(level)%wrk%wv)
write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',& !!$ write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',&
& size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv) !!$ & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv)
if (me >=0) then if (me >=0) then
if (level < nlev) then if (level < nlev) then
@ -664,7 +664,7 @@ contains
goto 9999 goto 9999
end if end if
write(0,*) me,' Map_rstr from ', level,' to ',level+1 !!$ write(0,*) me,' Map_rstr from ', level,' to ',level+1
call p%precv(level+1)%map_rstr(done,vty,& call p%precv(level+1)%map_rstr(done,vty,&
& dzero,p%precv(level+1)%wrk%vx2l,& & dzero,p%precv(level+1)%wrk%vx2l,&
& info,work=work,vtx=wv(1)) & info,work=work,vtx=wv(1))

3
amgprec/impl/amg_dprecinit.F90
Unescape Escape View File

@ -240,6 +240,8 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
do ilev_ = 1, nlev_ do ilev_ = 1, nlev_
call prec%precv(ilev_)%default() call prec%precv(ilev_)%default()
end do end do
call prec%set_nlevs(nlev_)
call prec%set('ML_CYCLE','VCYCLE',info) call prec%set('ML_CYCLE','VCYCLE',info)
call prec%set('SMOOTHER_TYPE','FBGS',info) call prec%set('SMOOTHER_TYPE','FBGS',info)
#if defined(AMG_HAVE_UMF) #if defined(AMG_HAVE_UMF)
@ -256,7 +258,6 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
&': Warning: Unknown preconditioner type request "',ptype,'"' &': Warning: Unknown preconditioner type request "',ptype,'"'
info = psb_err_pivot_too_small_ info = psb_err_pivot_too_small_
end select end select
call prec%set_nlevs(nlev_)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

26
amgprec/impl/level/amg_d_base_onelev_map_rstr.F90
Unescape Escape View File

@ -49,7 +49,7 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
type(psb_d_vect_type), pointer :: vty_ type(psb_d_vect_type), pointer :: vty_
integer(psb_mpk_) :: me, np integer(psb_mpk_) :: me, np
write(0,*) 'New map_rstr ',lv%remap_data%ac_pre_remap%is_asb() !!$ write(0,*) 'New map_rstr ',lv%remap_data%ac_pre_remap%is_asb()
if (present(vty)) then if (present(vty)) then
vty_ => vty vty_ => vty
else else
@ -60,7 +60,7 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
! !
! Remap has happened, deal with it ! Remap has happened, deal with it
! !
write(0,*) 'Level map_rstr with remapping ' !!$ write(0,*) 'Level map_rstr with remapping '
block block
type(psb_ctxt_type) :: ctxt, rctxt type(psb_ctxt_type) :: ctxt, rctxt
integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp
@ -72,25 +72,25 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
call psb_info(ctxt,me,np) call psb_info(ctxt,me,np)
rctxt = lv%desc_ac%get_ctxt() rctxt = lv%desc_ac%get_ctxt()
call psb_info(rctxt,rme,rnp) call psb_info(rctxt,rme,rnp)
write(0,*) 'New context map rstr',rme,rnp,me,np !!$ write(0,*) 'New context map rstr',rme,rnp,me,np
idest = lv%remap_data%idest idest = lv%remap_data%idest
associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc)
write(0,*) 'Should apply maps, then send data from ',me,' to ',idest !!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest
if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:) !!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:)
nsrc = size(isrc) nsrc = size(isrc)
nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows()
call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info)
call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v)
write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),& !!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),&
& psb_errstatus_fatal() !!$ & psb_errstatus_fatal()
flush(0) !!$ flush(0)
call psb_barrier(ctxt) call psb_barrier(ctxt)
call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,&
& work=work,vtx=vtx,vty=vty_) & work=work,vtx=vtx,vty=vty_)
!call tv%sync() !call tv%sync()
!rsnd = tv%get_vect() !rsnd = tv%get_vect()
!call psb_snd(ctxt,rsnd(1:nrl),idest) !call psb_snd(ctxt,rsnd(1:nrl),idest)
write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal() !!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal()
call psb_snd(ctxt,tv%v%v(1:nrl),idest) call psb_snd(ctxt,tv%v%v(1:nrl),idest)
if (rme >=0) then if (rme >=0) then
allocate(rrcv(sum(nrsrc))) allocate(rrcv(sum(nrsrc)))
@ -99,14 +99,14 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
do i = 1,size(isrc) do i = 1,size(isrc)
ip = isrc(i) ip = isrc(i)
nrl = nrsrc(i) nrl = nrsrc(i)
write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal() !!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal()
call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip)
kp = kp + nrl kp = kp + nrl
end do end do
call vect_v%set_vect(rrcv) call vect_v%set_vect(rrcv)
end if end if
end associate end associate
write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal() !!$ write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal()
end block end block
else else
@ -115,12 +115,12 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,&
type(psb_ctxt_type) :: ctxt, rctxt type(psb_ctxt_type) :: ctxt, rctxt
ctxt = lv%linmap%p_desc_U%get_ctxt() ctxt = lv%linmap%p_desc_U%get_ctxt()
call psb_info(ctxt,me,np) call psb_info(ctxt,me,np)
write(0,*) me,' map_rstr calling U2V: ',me,np !!$ write(0,*) me,' map_rstr calling U2V: ',me,np
call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,&
& work=work,vtx=vtx,vty=vty_) & work=work,vtx=vtx,vty=vty_)
end block end block
end if end if
write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal() !!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal()
end subroutine amg_d_base_onelev_map_rstr_v end subroutine amg_d_base_onelev_map_rstr_v
subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work)

20
samples/advanced/remap/amg_d_pde3d.F90
Unescape Escape View File

@ -473,10 +473,10 @@ program amg_d_pde3d
goto 9999 goto 9999
end if end if
do i=2, size(prec%precv) !!$ do i=2, size(prec%precv)
write(0,*) iam,'Between hier and smoothers_bld level',i,':',& !!$ write(0,*) iam,'Between hier and smoothers_bld level',i,':',&
& prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() !!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
end do !!$ end do
call psb_barrier(ctxt) call psb_barrier(ctxt)
t1 = psb_wtime() t1 = psb_wtime()
@ -497,11 +497,11 @@ program amg_d_pde3d
write(psb_out_unit,'(" ")') write(psb_out_unit,'(" ")')
end if end if
do i=2, size(prec%precv) !!$ do i=2, size(prec%precv)
write(0,*) iam,'After smoothers_bld level',i,':',& !!$ write(0,*) iam,'After smoothers_bld level',i,':',&
& prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb() !!$ & prec%precv(i)%remap_data%desc_ac_pre_remap%is_asb()
end do !!$ end do
!!$
call prec%descr(info,iout=psb_out_unit) call prec%descr(info,iout=psb_out_unit)
if (p_choice%dump) then if (p_choice%dump) then
@ -565,7 +565,7 @@ program amg_d_pde3d
call psb_sum(ctxt,amatsize) call psb_sum(ctxt,amatsize)
call psb_sum(ctxt,descsize) call psb_sum(ctxt,descsize)
call psb_sum(ctxt,precsize) call psb_sum(ctxt,precsize)
call prec%descr(info,iout=psb_out_unit) !!$ call prec%descr(info,iout=psb_out_unit)
if (iam == psb_root_) then if (iam == psb_root_) then
write(psb_out_unit,'("Computed solution on ",i8," process(es)")') np write(psb_out_unit,'("Computed solution on ",i8," process(es)")') np
write(psb_out_unit,'("Number of threads : ",i12)') nth write(psb_out_unit,'("Number of threads : ",i12)') nth

Write Preview
Loading…
Cancel
Save