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

mld2p4-NewNL:

Browse Source 
mlprec/Makefile
 mlprec/impl/mld_c_onelev_impl.f90
 mlprec/impl/mld_cmlprec_bld.f90
 mlprec/impl/mld_cprecinit.F90
 mlprec/impl/mld_cprecset.F90
 mlprec/impl/mld_d_onelev_impl.f90
 mlprec/impl/mld_dmlprec_bld.f90
 mlprec/impl/mld_s_onelev_impl.f90
 mlprec/impl/mld_smlprec_bld.f90
 mlprec/impl/mld_sprecinit.F90
 mlprec/impl/mld_sprecset.F90
 mlprec/impl/mld_z_onelev_impl.f90
 mlprec/impl/mld_zmlprec_bld.f90
 mlprec/impl/mld_zprecinit.F90
 mlprec/impl/mld_zprecset.F90
 mlprec/mld_base_prec_type.F90
 mlprec/mld_c_inner_mod.f90
 mlprec/mld_c_move_alloc_mod.f90
 mlprec/mld_c_onelev_mod.f90
 mlprec/mld_c_prec_mod.f90
 mlprec/mld_c_prec_type.f90
 mlprec/mld_d_inner_mod.f90
 mlprec/mld_d_move_alloc_mod.f90
 mlprec/mld_d_onelev_mod.f90
 mlprec/mld_d_prec_mod.f90
 mlprec/mld_d_prec_type.f90
 mlprec/mld_s_inner_mod.f90
 mlprec/mld_s_move_alloc_mod.f90
 mlprec/mld_s_onelev_mod.f90
 mlprec/mld_s_prec_mod.f90
 mlprec/mld_s_prec_type.f90
 mlprec/mld_z_inner_mod.f90
 mlprec/mld_z_move_alloc_mod.f90
 mlprec/mld_z_onelev_mod.f90
 mlprec/mld_z_prec_mod.f90
 mlprec/mld_z_prec_type.f90
 tests/pdegen/ppde2d.f90
 tests/pdegen/ppde3d.f90
 tests/pdegen/runs/ppde.inp
 tests/pdegen/spde2d.f90
 tests/pdegen/spde3d.f90

Working version of choice of levels with coarse space size.
stopcriterion
Salvatore Filippone 13 years ago
parent aab68f2bf3
commit 96ddd0a2bb
41 changed files with 1046 additions and 395 deletions
Show Stats Download Patch File Download Diff File

32
mlprec/Makefile
Unescape Escape View File

@ -7,22 +7,22 @@ HERE=.
FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR)
DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_move_alloc_mod.o mld_d_ilu_fact_mod.o \ DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_ilu_fact_mod.o \
mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \ mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \
mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o\ mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o\
mld_d_base_solver_mod.o mld_d_base_smoother_mod.o mld_d_onelev_mod.o mld_d_base_solver_mod.o mld_d_base_smoother_mod.o mld_d_onelev_mod.o
SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_move_alloc_mod.o mld_s_ilu_fact_mod.o \ SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_ilu_fact_mod.o \
mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \ mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \
mld_s_slu_solver.o mld_s_sludist_solver.o mld_s_id_solver.o\ mld_s_slu_solver.o mld_s_sludist_solver.o mld_s_id_solver.o\
mld_s_base_solver_mod.o mld_s_base_smoother_mod.o mld_s_onelev_mod.o mld_s_base_solver_mod.o mld_s_base_smoother_mod.o mld_s_onelev_mod.o
ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_move_alloc_mod.o mld_z_ilu_fact_mod.o \ ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_ilu_fact_mod.o \
mld_z_inner_mod.o mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \ mld_z_inner_mod.o mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \
mld_z_umf_solver.o mld_z_slu_solver.o mld_z_sludist_solver.o mld_z_id_solver.o\ mld_z_umf_solver.o mld_z_slu_solver.o mld_z_sludist_solver.o mld_z_id_solver.o\
mld_z_base_solver_mod.o mld_z_base_smoother_mod.o mld_z_onelev_mod.o mld_z_base_solver_mod.o mld_z_base_smoother_mod.o mld_z_onelev_mod.o
CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_move_alloc_mod.o mld_c_ilu_fact_mod.o \ CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_ilu_fact_mod.o \
mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \ mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \
mld_c_slu_solver.o mld_c_sludist_solver.o mld_c_id_solver.o\ mld_c_slu_solver.o mld_c_sludist_solver.o mld_c_id_solver.o\
mld_c_base_solver_mod.o mld_c_base_smoother_mod.o mld_c_onelev_mod.o mld_c_base_solver_mod.o mld_c_base_smoother_mod.o mld_c_onelev_mod.o
@ -63,20 +63,15 @@ $(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS)
$(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS) $(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS)
$(ZINNEROBJS) $(ZOUTEROBJS): $(ZMODOBJS) $(ZINNEROBJS) $(ZOUTEROBJS): $(ZMODOBJS)
mld_s_inner_mod.o: mld_s_move_alloc_mod.o mld_s_prec_type.o mld_s_inner_mod.o: mld_s_prec_type.o
mld_d_inner_mod.o: mld_d_move_alloc_mod.o mld_d_prec_type.o mld_d_inner_mod.o: mld_d_prec_type.o
mld_c_inner_mod.o: mld_c_move_alloc_mod.o mld_c_prec_type.o mld_c_inner_mod.o: mld_c_prec_type.o
mld_z_inner_mod.o: mld_z_move_alloc_mod.o mld_z_prec_type.o mld_z_inner_mod.o: mld_z_prec_type.o
mld_s_move_alloc_mod.o: mld_s_prec_type.o mld_s_prec_mod.o: mld_s_prec_type.o
mld_d_move_alloc_mod.o: mld_d_prec_type.o mld_d_prec_mod.o: mld_d_prec_type.o
mld_c_move_alloc_mod.o: mld_c_prec_type.o mld_c_prec_mod.o: mld_c_prec_type.o
mld_z_move_alloc_mod.o: mld_z_prec_type.o mld_z_prec_mod.o: mld_z_prec_type.o
mld_s_prec_mod.o: mld_s_move_alloc_mod.o
mld_d_prec_mod.o: mld_d_move_alloc_mod.o
mld_c_prec_mod.o: mld_c_move_alloc_mod.o
mld_z_prec_mod.o: mld_z_move_alloc_mod.o
mld_s_prec_type.o: mld_s_onelev_mod.o mld_s_prec_type.o: mld_s_onelev_mod.o
@ -97,9 +92,6 @@ mld_z_base_smoother_mod.o: mld_z_base_solver_mod.o
mld_s_base_solver_mod.o mld_d_base_solver_mod.o mld_c_base_solver_mod.o mld_z_base_solver_mod.o: mld_base_prec_type.o mld_s_base_solver_mod.o mld_d_base_solver_mod.o mld_c_base_solver_mod.o mld_z_base_solver_mod.o: mld_base_prec_type.o
mld_d_id_solver.o mld_d_sludist_solver.o mld_d_slu_solver.o \ mld_d_id_solver.o mld_d_sludist_solver.o mld_d_slu_solver.o \
mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_base_solver_mod.o mld_d_prec_type.o mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_base_solver_mod.o mld_d_prec_type.o

2
mlprec/impl/mld_c_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_c_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

267
mlprec/impl/mld_cmlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_cprec_type) :: t_prec type(mld_cprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_sml_parms) :: prm class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_sml_parms) :: baseparms, medparms, coarseparms
type(mld_c_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_c_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_cmlprec_bld end subroutine mld_cmlprec_bld

1
mlprec/impl/mld_cprecinit.F90
Unescape Escape View File

@ -125,6 +125,7 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
! Do we want to do something? ! Do we want to do something?
endif endif
endif endif
p%coarse_aggr_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype)))) select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE') case ('NOPREC','NONE')

5
mlprec/impl/mld_cprecset.F90
Unescape Escape View File

@ -129,6 +129,11 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
return return
endif endif
if (what == mld_coarse_aggr_size_) then
p%coarse_aggr_size = max(val,-1)
return
end if
! !
! Set preconditioner parameters at level ilev. ! Set preconditioner parameters at level ilev.
! !

2
mlprec/impl/mld_d_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_d_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

267
mlprec/impl/mld_dmlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_dprec_type) :: t_prec type(mld_dprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_dml_parms) :: prm class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_dml_parms) :: baseparms, medparms, coarseparms
type(mld_d_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_d_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_dmlprec_bld end subroutine mld_dmlprec_bld

2
mlprec/impl/mld_s_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_s_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

267
mlprec/impl/mld_smlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_sprec_type) :: t_prec type(mld_sprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_sml_parms) :: prm class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_sml_parms) :: baseparms, medparms, coarseparms
type(mld_s_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_s_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_smlprec_bld end subroutine mld_smlprec_bld

1
mlprec/impl/mld_sprecinit.F90
Unescape Escape View File

@ -125,6 +125,7 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
! Do we want to do something? ! Do we want to do something?
endif endif
endif endif
p%coarse_aggr_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype)))) select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE') case ('NOPREC','NONE')

5
mlprec/impl/mld_sprecset.F90
Unescape Escape View File

@ -129,6 +129,11 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
return return
endif endif
if (what == mld_coarse_aggr_size_) then
p%coarse_aggr_size = max(val,-1)
return
end if
! !
! Set preconditioner parameters at level ilev. ! Set preconditioner parameters at level ilev.
! !

2
mlprec/impl/mld_z_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_z_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

267
mlprec/impl/mld_zmlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_zprec_type) :: t_prec type(mld_zprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_dml_parms) :: prm class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_dml_parms) :: baseparms, medparms, coarseparms
type(mld_z_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_z_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then
!!$ if (me == 0) write(debug_unit,*)&
!!$ & 'Warning: inconsistent coarse level specification.'
!!$ if (me == 0) write(debug_unit,*)&
!!$ & ' Resetting according to the value specified for mld_coarse_solve_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_zmlprec_bld end subroutine mld_zmlprec_bld

1
mlprec/impl/mld_zprecinit.F90
Unescape Escape View File

@ -125,6 +125,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
! Do we want to do something? ! Do we want to do something?
endif endif
endif endif
p%coarse_aggr_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype)))) select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE') case ('NOPREC','NONE')

5
mlprec/impl/mld_zprecset.F90
Unescape Escape View File

@ -129,6 +129,11 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
return return
endif endif
if (what == mld_coarse_aggr_size_) then
p%coarse_aggr_size = max(val,-1)
return
end if
! !
! Set preconditioner parameters at level ilev. ! Set preconditioner parameters at level ilev.
! !

37
mlprec/mld_base_prec_type.F90
Unescape Escape View File

@ -104,6 +104,7 @@ module mld_base_prec_type
procedure, pass(pm) :: descr => ml_parms_descr procedure, pass(pm) :: descr => ml_parms_descr
procedure, pass(pm) :: mldescr => ml_parms_mldescr procedure, pass(pm) :: mldescr => ml_parms_mldescr
procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr
procedure, pass(pm) :: printout => ml_parms_printout
end type mld_ml_parms end type mld_ml_parms
@ -111,12 +112,14 @@ module mld_base_prec_type
real(psb_spk_) :: aggr_omega_val, aggr_thresh real(psb_spk_) :: aggr_omega_val, aggr_thresh
contains contains
procedure, pass(pm) :: descr => s_ml_parms_descr procedure, pass(pm) :: descr => s_ml_parms_descr
procedure, pass(pm) :: printout => s_ml_parms_printout
end type mld_sml_parms end type mld_sml_parms
type, extends(mld_ml_parms) :: mld_dml_parms type, extends(mld_ml_parms) :: mld_dml_parms
real(psb_dpk_) :: aggr_omega_val, aggr_thresh real(psb_dpk_) :: aggr_omega_val, aggr_thresh
contains contains
procedure, pass(pm) :: descr => d_ml_parms_descr procedure, pass(pm) :: descr => d_ml_parms_descr
procedure, pass(pm) :: printout => d_ml_parms_printout
end type mld_dml_parms end type mld_dml_parms
@ -437,6 +440,40 @@ contains
end subroutine mld_stringval end subroutine mld_stringval
subroutine ml_parms_printout(pm,iout)
implicit none
class(mld_ml_parms), intent(in) :: pm
integer, intent(in) :: iout
write(iout,*) 'Sweeps: ',pm%sweeps,pm%sweeps_pre,pm%sweeps_post
write(iout,*) 'ML : ',pm%ml_type,pm%smoother_pos
write(iout,*) 'AGGR : ',pm%aggr_alg,pm%aggr_kind
write(iout,*) ' : ',pm%aggr_omega_alg,pm%aggr_eig,pm%aggr_filter
write(iout,*) 'COARSE: ',pm%coarse_mat,pm%coarse_solve
end subroutine ml_parms_printout
subroutine s_ml_parms_printout(pm,iout)
implicit none
class(mld_sml_parms), intent(in) :: pm
integer, intent(in) :: iout
call pm%mld_ml_parms%printout(iout)
write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh
end subroutine s_ml_parms_printout
subroutine d_ml_parms_printout(pm,iout)
implicit none
class(mld_dml_parms), intent(in) :: pm
integer, intent(in) :: iout
call pm%mld_ml_parms%printout(iout)
write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh
end subroutine d_ml_parms_printout
! !
! Routines printing out a description of the preconditioner ! Routines printing out a description of the preconditioner
! !

2
mlprec/mld_c_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_c_inner_mod module mld_c_inner_mod
use mld_c_prec_type use mld_c_prec_type
use mld_c_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold)

1
mlprec/mld_c_move_alloc_mod.f90
Unescape Escape View File

@ -62,6 +62,7 @@ contains
integer, intent(out) :: info integer, intent(out) :: info
call b%free(info) call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm) call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)

26
mlprec/mld_c_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_c_onelev_mod
procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros
end type mld_c_onelev_type end type mld_c_onelev_type
type mld_c_onelev_node
type(mld_c_onelev_type) :: item
type(mld_c_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_c_onelev_node
private :: c_base_onelev_default, c_base_onelev_sizeof, & private :: c_base_onelev_default, c_base_onelev_sizeof, &
& c_base_onelev_nullify, c_base_onelev_get_nzeros & c_base_onelev_nullify, c_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_c_onelev_mod
end subroutine mld_c_base_onelev_dump end subroutine mld_c_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_c_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine c_base_onelev_default end subroutine c_base_onelev_default
subroutine mld_c_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_c_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_c_onelev_move_alloc
end module mld_c_onelev_mod end module mld_c_onelev_mod

1
mlprec/mld_c_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_c_prec_mod module mld_c_prec_mod
use mld_c_prec_type use mld_c_prec_type
use mld_c_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_cprecinit(p,ptype,info,nlev) subroutine mld_cprecinit(p,ptype,info,nlev)

34
mlprec/mld_c_prec_type.f90
Unescape Escape View File

@ -81,6 +81,7 @@ module mld_c_prec_type
type, extends(psb_cprec_type) :: mld_cprec_type type, extends(psb_cprec_type) :: mld_cprec_type
integer :: ictxt integer :: ictxt
integer(psb_ipk_) :: coarse_aggr_size
real(psb_spk_) :: op_complexity=szero real(psb_spk_) :: op_complexity=szero
type(mld_c_onelev_type), allocatable :: precv(:) type(mld_c_onelev_type), allocatable :: precv(:)
contains contains
@ -159,6 +160,10 @@ module mld_c_prec_type
end subroutine mld_cprecaply1 end subroutine mld_cprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_cprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -565,7 +570,7 @@ contains
if (present(istart)) then if (present(istart)) then
il1 = max(1,istart) il1 = max(1,istart)
else else
il1 = 2 il1 = min(2,iln)
end if end if
if (present(iend)) then if (present(iend)) then
iln = min(iln, iend) iln = min(iln, iend)
@ -577,5 +582,32 @@ contains
end do end do
end subroutine mld_c_dump end subroutine mld_c_dump
subroutine mld_cprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_cprec_type), intent(inout) :: a
type(mld_cprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_cprec_move_alloc
end module mld_c_prec_type end module mld_c_prec_type

2
mlprec/mld_d_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_d_inner_mod module mld_d_inner_mod
use mld_d_prec_type use mld_d_prec_type
use mld_d_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold)

1
mlprec/mld_d_move_alloc_mod.f90
Unescape Escape View File

@ -62,6 +62,7 @@ contains
integer, intent(out) :: info integer, intent(out) :: info
call b%free(info) call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm) call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)

26
mlprec/mld_d_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_d_onelev_mod
procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros
end type mld_d_onelev_type end type mld_d_onelev_type
type mld_d_onelev_node
type(mld_d_onelev_type) :: item
type(mld_d_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_d_onelev_node
private :: d_base_onelev_default, d_base_onelev_sizeof, & private :: d_base_onelev_default, d_base_onelev_sizeof, &
& d_base_onelev_nullify, d_base_onelev_get_nzeros & d_base_onelev_nullify, d_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_d_onelev_mod
end subroutine mld_d_base_onelev_dump end subroutine mld_d_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_d_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine d_base_onelev_default end subroutine d_base_onelev_default
subroutine mld_d_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_d_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_d_onelev_move_alloc
end module mld_d_onelev_mod end module mld_d_onelev_mod

1
mlprec/mld_d_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_d_prec_mod module mld_d_prec_mod
use mld_d_prec_type use mld_d_prec_type
use mld_d_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_dprecinit(p,ptype,info,nlev) subroutine mld_dprecinit(p,ptype,info,nlev)

35
mlprec/mld_d_prec_type.f90
Unescape Escape View File

@ -81,7 +81,7 @@ module mld_d_prec_type
type, extends(psb_dprec_type) :: mld_dprec_type type, extends(psb_dprec_type) :: mld_dprec_type
integer :: ictxt integer :: ictxt
integer :: coarse_aggr_size integer(psb_ipk_) :: coarse_aggr_size
real(psb_dpk_) :: op_complexity=dzero real(psb_dpk_) :: op_complexity=dzero
type(mld_d_onelev_type), allocatable :: precv(:) type(mld_d_onelev_type), allocatable :: precv(:)
contains contains
@ -160,6 +160,10 @@ module mld_d_prec_type
end subroutine mld_dprecaply1 end subroutine mld_dprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_dprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -566,7 +570,7 @@ contains
if (present(istart)) then if (present(istart)) then
il1 = max(1,istart) il1 = max(1,istart)
else else
il1 = 2 il1 = min(2,iln)
end if end if
if (present(iend)) then if (present(iend)) then
iln = min(iln, iend) iln = min(iln, iend)
@ -578,5 +582,32 @@ contains
end do end do
end subroutine mld_d_dump end subroutine mld_d_dump
subroutine mld_dprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_dprec_type), intent(inout) :: a
type(mld_dprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_dprec_move_alloc
end module mld_d_prec_type end module mld_d_prec_type

2
mlprec/mld_s_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_s_inner_mod module mld_s_inner_mod
use mld_s_prec_type use mld_s_prec_type
use mld_s_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold)

1
mlprec/mld_s_move_alloc_mod.f90
Unescape Escape View File

@ -62,6 +62,7 @@ contains
integer, intent(out) :: info integer, intent(out) :: info
call b%free(info) call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm) call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)

26
mlprec/mld_s_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_s_onelev_mod
procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros
end type mld_s_onelev_type end type mld_s_onelev_type
type mld_s_onelev_node
type(mld_s_onelev_type) :: item
type(mld_s_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_s_onelev_node
private :: s_base_onelev_default, s_base_onelev_sizeof, & private :: s_base_onelev_default, s_base_onelev_sizeof, &
& s_base_onelev_nullify, s_base_onelev_get_nzeros & s_base_onelev_nullify, s_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_s_onelev_mod
end subroutine mld_s_base_onelev_dump end subroutine mld_s_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_s_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine s_base_onelev_default end subroutine s_base_onelev_default
subroutine mld_s_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_s_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_s_onelev_move_alloc
end module mld_s_onelev_mod end module mld_s_onelev_mod

1
mlprec/mld_s_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_s_prec_mod module mld_s_prec_mod
use mld_s_prec_type use mld_s_prec_type
use mld_s_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_sprecinit(p,ptype,info,nlev) subroutine mld_sprecinit(p,ptype,info,nlev)

34
mlprec/mld_s_prec_type.f90
Unescape Escape View File

@ -81,6 +81,7 @@ module mld_s_prec_type
type, extends(psb_sprec_type) :: mld_sprec_type type, extends(psb_sprec_type) :: mld_sprec_type
integer :: ictxt integer :: ictxt
integer(psb_ipk_) :: coarse_aggr_size
real(psb_spk_) :: op_complexity=szero real(psb_spk_) :: op_complexity=szero
type(mld_s_onelev_type), allocatable :: precv(:) type(mld_s_onelev_type), allocatable :: precv(:)
contains contains
@ -159,6 +160,10 @@ module mld_s_prec_type
end subroutine mld_sprecaply1 end subroutine mld_sprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_sprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -565,7 +570,7 @@ contains
if (present(istart)) then if (present(istart)) then
il1 = max(1,istart) il1 = max(1,istart)
else else
il1 = 2 il1 = min(2,iln)
end if end if
if (present(iend)) then if (present(iend)) then
iln = min(iln, iend) iln = min(iln, iend)
@ -577,5 +582,32 @@ contains
end do end do
end subroutine mld_s_dump end subroutine mld_s_dump
subroutine mld_sprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_sprec_type), intent(inout) :: a
type(mld_sprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_sprec_move_alloc
end module mld_s_prec_type end module mld_s_prec_type

2
mlprec/mld_z_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_z_inner_mod module mld_z_inner_mod
use mld_z_prec_type use mld_z_prec_type
use mld_z_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold)

1
mlprec/mld_z_move_alloc_mod.f90
Unescape Escape View File

@ -62,6 +62,7 @@ contains
integer, intent(out) :: info integer, intent(out) :: info
call b%free(info) call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm) call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)

26
mlprec/mld_z_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_z_onelev_mod
procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros
end type mld_z_onelev_type end type mld_z_onelev_type
type mld_z_onelev_node
type(mld_z_onelev_type) :: item
type(mld_z_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_z_onelev_node
private :: z_base_onelev_default, z_base_onelev_sizeof, & private :: z_base_onelev_default, z_base_onelev_sizeof, &
& z_base_onelev_nullify, z_base_onelev_get_nzeros & z_base_onelev_nullify, z_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_z_onelev_mod
end subroutine mld_z_base_onelev_dump end subroutine mld_z_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_z_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine z_base_onelev_default end subroutine z_base_onelev_default
subroutine mld_z_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_z_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_z_onelev_move_alloc
end module mld_z_onelev_mod end module mld_z_onelev_mod

1
mlprec/mld_z_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_z_prec_mod module mld_z_prec_mod
use mld_z_prec_type use mld_z_prec_type
use mld_z_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_zprecinit(p,ptype,info,nlev) subroutine mld_zprecinit(p,ptype,info,nlev)

34
mlprec/mld_z_prec_type.f90
Unescape Escape View File

@ -81,6 +81,7 @@ module mld_z_prec_type
type, extends(psb_zprec_type) :: mld_zprec_type type, extends(psb_zprec_type) :: mld_zprec_type
integer :: ictxt integer :: ictxt
integer(psb_ipk_) :: coarse_aggr_size
real(psb_dpk_) :: op_complexity=dzero real(psb_dpk_) :: op_complexity=dzero
type(mld_z_onelev_type), allocatable :: precv(:) type(mld_z_onelev_type), allocatable :: precv(:)
contains contains
@ -159,6 +160,10 @@ module mld_z_prec_type
end subroutine mld_zprecaply1 end subroutine mld_zprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_zprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -565,7 +570,7 @@ contains
if (present(istart)) then if (present(istart)) then
il1 = max(1,istart) il1 = max(1,istart)
else else
il1 = 2 il1 = min(2,iln)
end if end if
if (present(iend)) then if (present(iend)) then
iln = min(iln, iend) iln = min(iln, iend)
@ -577,5 +582,32 @@ contains
end do end do
end subroutine mld_z_dump end subroutine mld_z_dump
subroutine mld_zprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_zprec_type), intent(inout) :: a
type(mld_zprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_zprec_move_alloc
end module mld_z_prec_type end module mld_z_prec_type

4
tests/pdegen/ppde2d.f90
Unescape Escape View File

@ -110,6 +110,7 @@ program ppde2d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -196,6 +197,7 @@ program ppde2d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -336,6 +338,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -373,6 +376,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

4
tests/pdegen/ppde3d.f90
Unescape Escape View File

@ -111,6 +111,7 @@ program ppde3d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -200,6 +201,7 @@ program ppde3d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -340,6 +342,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -377,6 +380,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

5
tests/pdegen/runs/ppde.inp
Unescape Escape View File

@ -1,6 +1,6 @@
BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG
CSR ! Storage format CSR COO JAD CSR ! Storage format CSR COO JAD
040 ! IDIM; domain size is idim**3 100 ! IDIM; domain size is idim**3
2 ! ISTOPC 2 ! ISTOPC
0100 ! ITMAX 0100 ! ITMAX
-1 ! ITRACE -1 ! ITRACE
@ -21,10 +21,11 @@ NONSMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED
DEC ! Type of aggregation DEC SYMDEC GLB DEC ! Type of aggregation DEC SYMDEC GLB
MULT ! Type of multilevel correction: ADD MULT MULT ! Type of multilevel correction: ADD MULT
TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD)
DIST ! Coarse level: matrix distribution DIST REPL REPL ! Coarse level: matrix distribution DIST REPL
BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST
ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST
1 ! Coarse level: Level-set N for ILU(N) 1 ! Coarse level: Level-set N for ILU(N)
1.d-4 ! Coarse level: Threshold T for ILU(T,P) 1.d-4 ! Coarse level: Threshold T for ILU(T,P)
4 ! Coarse level: Number of Jacobi sweeps 4 ! Coarse level: Number of Jacobi sweeps
-0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if <0 -0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if <0
100 ! Coarse size limit to determine levels. If <0, then use NL

4
tests/pdegen/spde2d.f90
Unescape Escape View File

@ -110,6 +110,7 @@ program spde2d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -196,6 +197,7 @@ program spde2d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -336,6 +338,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -373,6 +376,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

4
tests/pdegen/spde3d.f90
Unescape Escape View File

@ -111,6 +111,7 @@ program spde3d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -200,6 +201,7 @@ program spde3d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -340,6 +342,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -377,6 +380,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

Write Preview
Loading…
Cancel
Save