diff --git a/amgprec/amg_base_prec_type.F90 b/amgprec/amg_base_prec_type.F90 index 69ebf0ab..d96cdccb 100644 --- a/amgprec/amg_base_prec_type.F90 +++ b/amgprec/amg_base_prec_type.F90 @@ -81,10 +81,10 @@ module amg_base_prec_type ! ! Version numbers ! - character(len=*), parameter :: amg_version_string_ = "1.0.0" + character(len=*), parameter :: amg_version_string_ = "1.0.1" integer(psb_ipk_), parameter :: amg_version_major_ = 1 integer(psb_ipk_), parameter :: amg_version_minor_ = 0 - integer(psb_ipk_), parameter :: amg_patchlevel_ = 0 + integer(psb_ipk_), parameter :: amg_patchlevel_ = 1 type amg_ml_parms integer(psb_ipk_) :: sweeps_pre, sweeps_post diff --git a/amgprec/amg_c_base_aggregator_mod.f90 b/amgprec/amg_c_base_aggregator_mod.f90 index 42d7d140..93250ba5 100644 --- a/amgprec/amg_c_base_aggregator_mod.f90 +++ b/amgprec/amg_c_base_aggregator_mod.f90 @@ -126,7 +126,7 @@ module amg_c_base_aggregator_mod & psb_c_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_ implicit none type(psb_c_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_c_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr @@ -144,7 +144,7 @@ module amg_c_base_aggregator_mod & psb_c_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_ implicit none type(psb_c_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_c_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr diff --git a/amgprec/amg_d_base_aggregator_mod.f90 b/amgprec/amg_d_base_aggregator_mod.f90 index ef87f42e..14e2cd64 100644 --- a/amgprec/amg_d_base_aggregator_mod.f90 +++ b/amgprec/amg_d_base_aggregator_mod.f90 @@ -126,7 +126,7 @@ module amg_d_base_aggregator_mod & psb_d_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_ implicit none type(psb_d_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_d_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr @@ -144,7 +144,7 @@ module amg_d_base_aggregator_mod & psb_d_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_ implicit none type(psb_d_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_d_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr diff --git a/amgprec/amg_d_matchboxp_mod.f90 b/amgprec/amg_d_matchboxp_mod.f90 index 5847e97f..a18d62d6 100644 --- a/amgprec/amg_d_matchboxp_mod.f90 +++ b/amgprec/amg_d_matchboxp_mod.f90 @@ -68,7 +68,7 @@ ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. ! -module dmatchboxp_mod +module amg_d_matchboxp_mod use iso_c_binding use psb_base_cbind_mod @@ -94,34 +94,25 @@ module dmatchboxp_mod end subroutine dMatchBoxPC end interface MatchBoxPC - interface i_aggr_assign - module procedure i_daggr_assign - end interface i_aggr_assign + interface amg_i_aggr_assign + module procedure amg_i_d_aggr_assign + end interface amg_i_aggr_assign - interface build_matching - module procedure dbuild_matching - end interface build_matching + interface amg_par_build_matching + module procedure amg_d_par_build_matching + end interface amg_par_build_matching - interface build_ahat - module procedure dbuild_ahat - end interface build_ahat + interface amg_par_build_ahat + module procedure amg_d_par_build_ahat + end interface amg_par_build_ahat - interface psb_gtranspose - module procedure psb_dgtranspose - end interface psb_gtranspose + interface amg_PMatchBox + module procedure amg_d_PMatchBox + end interface amg_PMatchBox - interface psb_htranspose - module procedure psb_dhtranspose - end interface psb_htranspose - - interface PMatchBox - module procedure dPMatchBox - end interface PMatchBox - - logical, parameter, private :: print_statistics=.false. contains - subroutine dmatchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,& + subroutine amg_d_matchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,& & symmetrize,reproducible,display_inp, display_out, print_out) use psb_base_mod use psb_util_mod @@ -214,7 +205,7 @@ contains end if if (do_timings) call psb_toc(idx_phase1) if (do_timings) call psb_tic(idx_bldmtc) - call build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize) + call amg_par_build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize) if (do_timings) call psb_toc(idx_bldmtc) if (debug) write(0,*) iam,' buildprol from buildmatching:',& & info @@ -312,7 +303,7 @@ contains ! Should be a symmetric function. ! call desc_a%indxmap%qry_halo_owner(idx,iown,info) - ip = i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) + ip = amg_i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) if (iam == ip) then nlaggr(iam) = nlaggr(iam) + 1 ilaggr(k) = nlaggr(iam) @@ -422,13 +413,11 @@ contains nlpairs = v(3) end block - if (print_statistics) then - if (iam == 0) then - write(0,*) 'Matching statistics: Unmatched nodes ',& - & nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs - end if + if (iam == 0) then + write(0,*) 'Matching statistics: Unmatched nodes ',& + & nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs end if - + if (display_out_) then block integer(psb_ipk_) :: idx @@ -516,9 +505,9 @@ contains write(0,*) iam,' : error from Matching: ',info end if - end subroutine dmatchboxp_build_prol + end subroutine amg_d_matchboxp_build_prol - function i_daggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) & + function amg_i_d_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) & & result(iproc) ! ! How to break ties? This @@ -560,10 +549,10 @@ contains iproc = iown end if end if - end function i_daggr_assign + end function amg_i_d_aggr_assign - subroutine dbuild_matching(w,a,desc_a,mate,info,display_inp, symmetrize) + subroutine amg_d_par_build_matching(w,a,desc_a,mate,info,display_inp, symmetrize) use psb_base_mod use psb_util_mod use iso_c_binding @@ -612,7 +601,7 @@ contains if (iam == 0) write(0,*)' Into build_ahat:' end if if (do_timings) call psb_tic(idx_bldahat) - call build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize) + call amg_par_build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize) if (do_timings) call psb_toc(idx_bldahat) if (info /= 0) then write(0,*) 'Error from build_ahat ', info @@ -703,7 +692,7 @@ contains ! if (debug) write(0,*) iam,' buildmatching into PMatchBox:' if (do_timings) call psb_tic(idx_cmboxp) - call PMatchBox(nr,nz,vlptr,vlind,ewght,& + call amg_PMatchBox(nr,nz,vlptr,vlind,ewght,& & vnl, mate, iam, np,ictxt,& & msgis,msgas,msgprc,ph0t,ph1t,ph2t,ph1crd,ph2crd,info,display_inp) if (do_timings) call psb_toc(idx_cmboxp) @@ -767,9 +756,9 @@ contains val(1:n) = tmp(1:n) end subroutine fix_order - end subroutine dbuild_matching + end subroutine amg_d_par_build_matching - subroutine dbuild_ahat(w,a,ahat,desc_a,info,symmetrize) + subroutine amg_d_par_build_ahat(w,a,ahat,desc_a,info,symmetrize) use psb_base_mod implicit none real(psb_dpk_), intent(in) :: w(:) @@ -1005,301 +994,9 @@ contains end block end if - end subroutine dbuild_ahat + end subroutine amg_d_par_build_ahat - subroutine psb_dgtranspose(ain,aout,desc_a,info) - use psb_base_mod - implicit none - type(psb_ldspmat_type), intent(in) :: ain - type(psb_ldspmat_type), intent(out) :: aout - type(psb_desc_type) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! - ! BEWARE: This routine works under the assumption - ! that the same DESC_A works for both A and A^T, which - ! essentially means that A has a symmetric pattern. - ! - type(psb_ldspmat_type) :: atmp, ahalo, aglb - type(psb_ld_coo_sparse_mat) :: tmpcoo - type(psb_ld_csr_sparse_mat) :: tmpcsr - type(psb_ctxt_type) :: ictxt - integer(psb_ipk_) :: me, np - integer(psb_lpk_) :: i, j, k, nrow, ncol - integer(psb_lpk_), allocatable :: ilv(:) - character(len=80) :: aname - logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'Start gtranspose ' - end if - call ain%cscnv(tmpcsr,info) - - if (debug) then - ilv = [(i,i=1,ncol)] - call desc_a%l2gip(ilv,info,owned=.false.) - write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx' - call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv) - end if - if (dump) then - call ain%cscnv(atmp,info) - call psb_gather(aglb,atmp,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - !call psb_loc_to_glob(tmpcsr%ja,desc_a,info) - call atmp%mv_from(tmpcsr) - - if (debug) then - write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx' - call atmp%print(fname=aname,head='tmpcsr ',iv=ilv) - !call psb_set_debug_level(9999) - end if - - ! FIXME THIS NEEDS REWORKING - if (debug) write(0,*) me,' Gtranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols() - call psb_sphalo(atmp,desc_a,ahalo,info,rowscale=.true.) - if (debug) write(0,*) me,' Gtranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols() - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo) - - if (debug) then - write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx' - call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv) - write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx' - call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv) - end if - - if (info == psb_success_) call ahalo%free() - - call atmp%cp_to(tmpcoo) - call tmpcoo%transp() - !call psb_glob_to_loc(tmpcoo%ia,desc_a,info,iact='I') - if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros() - - j = 0 - do k=1, tmpcoo%get_nzeros() - if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then - j = j+1 - tmpcoo%ia(j) = tmpcoo%ia(k) - tmpcoo%ja(j) = tmpcoo%ja(k) - tmpcoo%val(j) = tmpcoo%val(k) - end if - end do - call tmpcoo%set_nzeros(j) - - if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros() - - call ahalo%mv_from(tmpcoo) - if (dump) then - call psb_gather(aglb,ahalo,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran-preclip.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - - call ahalo%csclip(aout,info,imax=nrow) - - if (debug) write(0,*) 'After clip:',aout%get_nzeros() - - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'End gtranspose ' - end if - !call aout%cscnv(info,type='csr') - - if (dump) then - write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx' - call aout%print(fname=aname,head='atrans ',iv=ilv) - call psb_gather(aglb,aout,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - end subroutine psb_dgtranspose - - subroutine psb_dhtranspose(ain,aout,desc_a,info) - use psb_base_mod - implicit none - type(psb_ldspmat_type), intent(in) :: ain - type(psb_ldspmat_type), intent(out) :: aout - type(psb_desc_type) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! - ! BEWARE: This routine works under the assumption - ! that the same DESC_A works for both A and A^T, which - ! essentially means that A has a symmetric pattern. - ! - type(psb_ldspmat_type) :: atmp, ahalo, aglb - type(psb_ld_coo_sparse_mat) :: tmpcoo, tmpc1, tmpc2, tmpch - type(psb_ld_csr_sparse_mat) :: tmpcsr - integer(psb_ipk_) :: nz1, nz2, nzh, nz - type(psb_ctxt_type) :: ictxt - integer(psb_ipk_) :: me, np - integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz - integer(psb_lpk_), allocatable :: ilv(:) - character(len=80) :: aname - logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'Start htranspose ' - end if - call ain%cscnv(tmpcsr,info) - - if (debug) then - ilv = [(i,i=1,ncol)] - call desc_a%l2gip(ilv,info,owned=.false.) - write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx' - call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv) - end if - if (dump) then - call ain%cscnv(atmp,info) - call psb_gather(aglb,atmp,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - !call psb_loc_to_glob(tmpcsr%ja,desc_a,info) - call atmp%mv_from(tmpcsr) - - if (debug) then - write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx' - call atmp%print(fname=aname,head='tmpcsr ',iv=ilv) - !call psb_set_debug_level(9999) - end if - - ! FIXME THIS NEEDS REWORKING - if (debug) write(0,*) me,' Htranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols() - if (.true.) then - call psb_sphalo(atmp,desc_a,ahalo,info, outfmt='coo ') - call atmp%mv_to(tmpc1) - call ahalo%mv_to(tmpch) - nz1 = tmpc1%get_nzeros() - call psb_loc_to_glob(tmpc1%ia(1:nz1),desc_a,info,iact='I') - call psb_loc_to_glob(tmpc1%ja(1:nz1),desc_a,info,iact='I') - nzh = tmpch%get_nzeros() - call psb_loc_to_glob(tmpch%ia(1:nzh),desc_a,info,iact='I') - call psb_loc_to_glob(tmpch%ja(1:nzh),desc_a,info,iact='I') - nlz = nz1+nzh - call tmpcoo%allocate(ncol,ncol,nlz) - tmpcoo%ia(1:nz1) = tmpc1%ia(1:nz1) - tmpcoo%ja(1:nz1) = tmpc1%ja(1:nz1) - tmpcoo%val(1:nz1) = tmpc1%val(1:nz1) - tmpcoo%ia(nz1+1:nz1+nzh) = tmpch%ia(1:nzh) - tmpcoo%ja(nz1+1:nz1+nzh) = tmpch%ja(1:nzh) - tmpcoo%val(nz1+1:nz1+nzh) = tmpch%val(1:nzh) - call tmpcoo%set_nzeros(nlz) - call tmpcoo%transp() - nz = tmpcoo%get_nzeros() - call psb_glob_to_loc(tmpcoo%ia(1:nz),desc_a,info,iact='I') - call psb_glob_to_loc(tmpcoo%ja(1:nz),desc_a,info,iact='I') - if (.true.) then - call tmpcoo%clean_negidx(info) - else - j = 0 - do k=1, tmpcoo%get_nzeros() - if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then - j = j+1 - tmpcoo%ia(j) = tmpcoo%ia(k) - tmpcoo%ja(j) = tmpcoo%ja(k) - tmpcoo%val(j) = tmpcoo%val(k) - end if - end do - call tmpcoo%set_nzeros(j) - end if - call ahalo%mv_from(tmpcoo) - call ahalo%csclip(aout,info,imax=nrow) - - else - call psb_sphalo(atmp,desc_a,ahalo,info, rowscale=.true.) - if (debug) write(0,*) me,' Htranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols() - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo) - - if (debug) then - write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx' - call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv) - write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx' - call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv) - end if - - if (info == psb_success_) call ahalo%free() - - call atmp%cp_to(tmpcoo) - call tmpcoo%transp() - if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros() - if (.true.) then - call tmpcoo%clean_negidx(info) - else - - j = 0 - do k=1, tmpcoo%get_nzeros() - if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then - j = j+1 - tmpcoo%ia(j) = tmpcoo%ia(k) - tmpcoo%ja(j) = tmpcoo%ja(k) - tmpcoo%val(j) = tmpcoo%val(k) - end if - end do - call tmpcoo%set_nzeros(j) - end if - - if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros() - - call ahalo%mv_from(tmpcoo) - if (dump) then - call psb_gather(aglb,ahalo,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran-preclip.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - - call ahalo%csclip(aout,info,imax=nrow) - end if - - if (debug) write(0,*) 'After clip:',aout%get_nzeros() - - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'End htranspose ' - end if - !call aout%cscnv(info,type='csr') - - if (dump) then - write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx' - call aout%print(fname=aname,head='atrans ',iv=ilv) - call psb_gather(aglb,aout,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - end subroutine psb_dhtranspose - - subroutine dPMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,& + subroutine amg_d_PMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,& & verdistance, mate, myrank, numprocs, ictxt,& & msgindsent,msgactualsent,msgpercent,& & ph0_time, ph1_time, ph2_time, ph1_card, ph2_card,info,display_inp) @@ -1434,6 +1131,6 @@ contains end if where(mate>=0) mate = mate + 1 - end subroutine dPMatchBox + end subroutine amg_d_PMatchBox -end module dmatchboxp_mod +end module amg_d_matchboxp_mod diff --git a/amgprec/amg_d_parmatch_aggregator_mod.F90 b/amgprec/amg_d_parmatch_aggregator_mod.F90 index fdbf961a..d50280d3 100644 --- a/amgprec/amg_d_parmatch_aggregator_mod.F90 +++ b/amgprec/amg_d_parmatch_aggregator_mod.F90 @@ -118,7 +118,7 @@ module amg_d_parmatch_aggregator_mod use amg_d_base_aggregator_mod - use dmatchboxp_mod + use amg_d_matchboxp_mod #if defined(SERIAL_MPI) type, extends(amg_d_base_aggregator_type) :: amg_d_parmatch_aggregator_type end type amg_d_parmatch_aggregator_type @@ -132,8 +132,6 @@ module amg_d_parmatch_aggregator_mod type(psb_dspmat_type), allocatable :: prol, restr type(psb_dspmat_type), allocatable :: ac, base_a, rwa type(psb_desc_type), allocatable :: desc_ac, desc_ax, base_desc, rwdesc - integer(psb_ipk_) :: max_csize - integer(psb_ipk_) :: max_nlevels logical :: reproducible_matching = .false. logical :: need_symmetrize = .false. logical :: unsmoothed_hierarchy = .true. @@ -143,18 +141,18 @@ module amg_d_parmatch_aggregator_mod procedure, pass(ag) :: mat_asb => amg_d_parmatch_aggregator_mat_asb procedure, pass(ag) :: inner_mat_asb => amg_d_parmatch_aggregator_inner_mat_asb procedure, pass(ag) :: bld_map => amg_d_parmatch_aggregator_bld_map - procedure, pass(ag) :: csetc => d_parmatch_aggr_csetc - procedure, pass(ag) :: cseti => d_parmatch_aggr_cseti - procedure, pass(ag) :: default => d_parmatch_aggr_set_default - procedure, pass(ag) :: sizeof => d_parmatch_aggregator_sizeof - procedure, pass(ag) :: update_next => d_parmatch_aggregator_update_next - procedure, pass(ag) :: bld_wnxt => d_parmatch_bld_wnxt - procedure, pass(ag) :: bld_default_w => d_bld_default_w - procedure, pass(ag) :: set_c_default_w => d_set_prm_c_default_w - procedure, pass(ag) :: descr => d_parmatch_aggregator_descr - procedure, pass(ag) :: clone => d_parmatch_aggregator_clone - procedure, pass(ag) :: free => d_parmatch_aggregator_free - procedure, nopass :: fmt => d_parmatch_aggregator_fmt + procedure, pass(ag) :: csetc => amg_d_parmatch_aggr_csetc + procedure, pass(ag) :: cseti => amg_d_parmatch_aggr_cseti + procedure, pass(ag) :: default => amg_d_parmatch_aggr_set_default + procedure, pass(ag) :: sizeof => amg_d_parmatch_aggregator_sizeof + procedure, pass(ag) :: update_next => amg_d_parmatch_aggregator_update_next + procedure, pass(ag) :: bld_wnxt => amg_d_parmatch_bld_wnxt + procedure, pass(ag) :: bld_default_w => amg_d_bld_default_w + procedure, pass(ag) :: set_c_default_w => amg_d_set_prm_c_default_w + procedure, pass(ag) :: descr => amg_d_parmatch_aggregator_descr + procedure, pass(ag) :: clone => amg_d_parmatch_aggregator_clone + procedure, pass(ag) :: free => amg_d_parmatch_aggregator_free + procedure, nopass :: fmt => amg_d_parmatch_aggregator_fmt procedure, nopass :: xt_desc => amg_d_parmatch_aggregator_xt_desc end type amg_d_parmatch_aggregator_type @@ -168,7 +166,7 @@ module amg_d_parmatch_aggregator_mod type(amg_dml_parms), intent(inout) :: parms type(amg_daggr_data), intent(in) :: ag_data type(psb_dspmat_type), intent(inout) :: a - type(psb_desc_type), intent(inout) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_ldspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info @@ -235,7 +233,7 @@ module amg_d_parmatch_aggregator_mod & psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data implicit none type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol @@ -257,7 +255,7 @@ module amg_d_parmatch_aggregator_mod integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol - type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_d_parmatch_unsmth_bld @@ -275,7 +273,7 @@ module amg_d_parmatch_aggregator_mod integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol - type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_d_parmatch_smth_bld @@ -288,11 +286,11 @@ module amg_d_parmatch_aggregator_mod & psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data implicit none type(psb_dspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol - type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(out) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_d_parmatch_spmm_bld_ov @@ -306,11 +304,11 @@ module amg_d_parmatch_aggregator_mod & psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat implicit none type(psb_d_csr_sparse_mat), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol - type(psb_dspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(out) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_d_parmatch_spmm_bld_inner @@ -320,7 +318,7 @@ module amg_d_parmatch_aggregator_mod contains - subroutine d_bld_default_w(ag,nr) + subroutine amg_d_bld_default_w(ag,nr) use psb_realloc_mod implicit none class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag @@ -330,9 +328,9 @@ contains if (info /= psb_success_) return ag%w = done !call ag%set_c_default_w() - end subroutine d_bld_default_w + end subroutine amg_d_bld_default_w - subroutine d_set_prm_c_default_w(ag) + subroutine amg_d_set_prm_c_default_w(ag) use psb_realloc_mod use iso_c_binding implicit none @@ -342,9 +340,9 @@ contains !write(0,*) 'prm_c_deafult_w ' call psb_safe_ab_cpy(ag%w,ag%w_nxt,info) - end subroutine d_set_prm_c_default_w + end subroutine amg_d_set_prm_c_default_w - subroutine d_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx) + subroutine amg_d_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx) use psb_realloc_mod implicit none class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag @@ -358,14 +356,14 @@ contains !write(0,*) 'Executing bld_wnxt ',nx call psb_realloc(nx,ag%w_nxt,info) - end subroutine d_parmatch_bld_wnxt + end subroutine amg_d_parmatch_bld_wnxt - function d_parmatch_aggregator_fmt() result(val) + function amg_d_parmatch_aggregator_fmt() result(val) implicit none character(len=32) :: val val = "Parallel Matching aggregation" - end function d_parmatch_aggregator_fmt + end function amg_d_parmatch_aggregator_fmt function amg_d_parmatch_aggregator_xt_desc() result(val) implicit none @@ -374,7 +372,7 @@ contains val = .true. end function amg_d_parmatch_aggregator_xt_desc - function d_parmatch_aggregator_sizeof(ag) result(val) + function amg_d_parmatch_aggregator_sizeof(ag) result(val) use psb_realloc_mod implicit none class(amg_d_parmatch_aggregator_type), intent(in) :: ag @@ -390,9 +388,9 @@ contains if (allocated(ag%base_desc)) val = val + ag%base_desc%sizeof() if (allocated(ag%desc_ax)) val = val + ag%desc_ax%sizeof() - end function d_parmatch_aggregator_sizeof + end function amg_d_parmatch_aggregator_sizeof - subroutine d_parmatch_aggregator_descr(ag,parms,iout,info) + subroutine amg_d_parmatch_aggregator_descr(ag,parms,iout,info) implicit none class(amg_d_parmatch_aggregator_type), intent(in) :: ag type(amg_dml_parms), intent(in) :: parms @@ -406,7 +404,7 @@ contains call parms%mldescr(iout,info) return - end subroutine d_parmatch_aggregator_descr + end subroutine amg_d_parmatch_aggregator_descr function is_legal_malg(alg) result(val) logical :: val @@ -437,7 +435,7 @@ contains end function is_legal_nlevels - subroutine d_parmatch_aggregator_update_next(ag,agnext,info) + subroutine amg_d_parmatch_aggregator_update_next(ag,agnext,info) use psb_realloc_mod implicit none class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag @@ -452,10 +450,10 @@ contains & agnext%matching_alg = ag%matching_alg if (.not.is_legal_nsweeps(agnext%n_sweeps))& & agnext%n_sweeps = ag%n_sweeps - if (.not.is_legal_csize(agnext%max_csize))& - & agnext%max_csize = ag%max_csize - if (.not.is_legal_nlevels(agnext%max_nlevels))& - & agnext%max_nlevels = ag%max_nlevels +!!$ if (.not.is_legal_csize(agnext%max_csize))& +!!$ & agnext%max_csize = ag%max_csize +!!$ if (.not.is_legal_nlevels(agnext%max_nlevels))& +!!$ & agnext%max_nlevels = ag%max_nlevels ! Is this going to generate shallow copies/memory leaks/double frees? ! To be investigated further. call psb_safe_ab_cpy(ag%w_nxt,agnext%w,info) @@ -470,9 +468,9 @@ contains ! What should we do here? end select info = 0 - end subroutine d_parmatch_aggregator_update_next + end subroutine amg_d_parmatch_aggregator_update_next - subroutine d_parmatch_aggr_csetc(ag,what,val,info,idx) + subroutine amg_d_parmatch_aggr_csetc(ag,what,val,info,idx) Implicit None @@ -514,9 +512,9 @@ contains ! Do nothing end select return - end subroutine d_parmatch_aggr_csetc + end subroutine amg_d_parmatch_aggr_csetc - subroutine d_parmatch_aggr_cseti(ag,what,val,info,idx) + subroutine amg_d_parmatch_aggr_cseti(ag,what,val,info,idx) Implicit None @@ -540,10 +538,6 @@ contains case('AGGR_SIZE') ag%orig_aggr_size = val ag%n_sweeps=max(1,ceiling(log(val*1.0)/log(2.0))) - case('PRMC_MAX_CSIZE') - ag%max_csize=val - case('PRMC_MAX_NLEVELS') - ag%max_nlevels=val case('PRMC_W_SIZE') call ag%bld_default_w(val) case('PRMC_REPRODUCIBLE_MATCHING') @@ -556,9 +550,9 @@ contains ! Do nothing end select return - end subroutine d_parmatch_aggr_cseti + end subroutine amg_d_parmatch_aggr_cseti - subroutine d_parmatch_aggr_set_default(ag) + subroutine amg_d_parmatch_aggr_set_default(ag) Implicit None @@ -569,8 +563,8 @@ contains ag%matching_alg = 0 ag%n_sweeps = 1 ag%jacobi_sweeps = 0 - ag%max_nlevels = 36 - ag%max_csize = -1 +!!$ ag%max_nlevels = 36 +!!$ ag%max_csize = -1 ! ! Apparently BootCMatch works better ! by keeping all entries @@ -579,9 +573,9 @@ contains return - end subroutine d_parmatch_aggr_set_default + end subroutine amg_d_parmatch_aggr_set_default - subroutine d_parmatch_aggregator_free(ag,info) + subroutine amg_d_parmatch_aggregator_free(ag,info) use iso_c_binding implicit none class(amg_d_parmatch_aggregator_type), intent(inout) :: ag @@ -618,9 +612,9 @@ contains call ag%rwdesc%free(info); deallocate(ag%rwdesc,stat=info) end if - end subroutine d_parmatch_aggregator_free + end subroutine amg_d_parmatch_aggregator_free - subroutine d_parmatch_aggregator_clone(ag,agnext,info) + subroutine amg_d_parmatch_aggregator_clone(ag,agnext,info) implicit none class(amg_d_parmatch_aggregator_type), intent(inout) :: ag class(amg_d_base_aggregator_type), allocatable, intent(inout) :: agnext @@ -640,7 +634,7 @@ contains ! Should never ever get here info = -1 end select - end subroutine d_parmatch_aggregator_clone + end subroutine amg_d_parmatch_aggregator_clone subroutine amg_d_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,& & op_restr,op_prol,map,info) diff --git a/amgprec/amg_d_sludist_solver.F90 b/amgprec/amg_d_sludist_solver.F90 index a196bbfa..40c4925f 100644 --- a/amgprec/amg_d_sludist_solver.F90 +++ b/amgprec/amg_d_sludist_solver.F90 @@ -52,7 +52,7 @@ module amg_d_sludist_solver use iso_c_binding use amg_d_base_solver_mod -#if defined(LPK8) +#if (!defined(HAVE_SLUDIST_)) || defined(IPK8) type, extends(amg_d_base_solver_type) :: amg_d_sludist_solver_type @@ -270,11 +270,13 @@ contains ! Local variables type(psb_dspmat_type) :: atmp type(psb_d_csr_sparse_mat) :: acsr - integer :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc - integer :: ifrst, ibcheck + integer(psb_lpk_), allocatable :: gia(:), gja(:) type(psb_ctxt_type) :: ctxt - integer :: np,me,i, err_act, debug_unit, debug_level - character(len=20) :: name='d_sludist_solver_bld', ch_err + integer(psb_lpk_) :: lfrst + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc + integer(psb_ipk_) :: ifrst, ibcheck + integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_sludist_solver_bld', ch_err info=psb_success_ call psb_erractionsave(err_act) @@ -293,19 +295,37 @@ contains n_col = desc_a%get_local_cols() nglob = desc_a%get_global_rows() - call a%cscnv(atmp,info,type='coo') + ! + ! Strategy here is as follows: because a call to SLUDIST + ! as a gobal solver is mostly done at the coarsest level, + ! even if we start from a problem requiring 8 bytes, chances + ! are that the global size will be suitable for 4 bytes + ! anyway, so we hope for the best, and throw an error + ! if something goes wrong. + ! + if (nglob > huge(1_psb_ipk_)) then + write(0,*) me,' ',trim(name),': Error: overflow of local indices ' + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%cscnv(atmp,info,type='csr') + ! This in case we are dealing with AS call psb_rwextd(n_row,atmp,info,b=b) - call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_) call atmp%mv_to(acsr) nrow_a = acsr%get_nrows() nztota = acsr%get_nzeros() + call psb_loc_to_glob(ione,lfrst,desc_a,info) + ! Fix the entries to call C-base SuperLU - call psb_loc_to_glob(1,ifrst,desc_a,info) - call psb_loc_to_glob(nrow_a,ibcheck,desc_a,info) - call psb_loc_to_glob(acsr%ja(1:nztota),desc_a,info,iact='I') + call psb_realloc(nztota,gja,info) + call psb_loc_to_glob(acsr%ja(1:nztota),gja(1:nztota), desc_a, info, iact='I') + acsr%ja(1:nztota) = gja(1:nztota) acsr%ja(:) = acsr%ja(:) - 1 acsr%irp(:) = acsr%irp(:) - 1 - ifrst = ifrst - 1 + ifrst = lfrst - 1 + info = amg_dsludist_fact(nglob,nrow_a,nztota,ifrst,& & acsr%val,acsr%irp,acsr%ja,sv%lufactors,& & npr,npc) @@ -318,7 +338,6 @@ contains end if call acsr%free() - call atmp%free() if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),' end' diff --git a/amgprec/amg_s_base_aggregator_mod.f90 b/amgprec/amg_s_base_aggregator_mod.f90 index f1039639..2c07fc4a 100644 --- a/amgprec/amg_s_base_aggregator_mod.f90 +++ b/amgprec/amg_s_base_aggregator_mod.f90 @@ -126,7 +126,7 @@ module amg_s_base_aggregator_mod & psb_s_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_ implicit none type(psb_s_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_s_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr @@ -144,7 +144,7 @@ module amg_s_base_aggregator_mod & psb_s_coo_sparse_mat, amg_sml_parms, psb_spk_, psb_ipk_, psb_lpk_ implicit none type(psb_s_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_s_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr diff --git a/amgprec/amg_s_matchboxp_mod.f90 b/amgprec/amg_s_matchboxp_mod.f90 index 5d3f2266..9061344f 100644 --- a/amgprec/amg_s_matchboxp_mod.f90 +++ b/amgprec/amg_s_matchboxp_mod.f90 @@ -68,7 +68,7 @@ ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. ! -module smatchboxp_mod +module amg_s_matchboxp_mod use iso_c_binding use psb_base_cbind_mod @@ -94,34 +94,25 @@ module smatchboxp_mod end subroutine sMatchBoxPC end interface MatchBoxPC - interface i_aggr_assign - module procedure i_saggr_assign - end interface i_aggr_assign + interface amg_i_aggr_assign + module procedure amg_i_s_aggr_assign + end interface amg_i_aggr_assign - interface build_matching - module procedure sbuild_matching - end interface build_matching + interface amg_par_build_matching + module procedure amg_s_par_build_matching + end interface amg_par_build_matching - interface build_ahat - module procedure sbuild_ahat - end interface build_ahat + interface amg_par_build_ahat + module procedure amg_s_par_build_ahat + end interface amg_par_build_ahat - interface psb_gtranspose - module procedure psb_sgtranspose - end interface psb_gtranspose + interface amg_PMatchBox + module procedure amg_s_PMatchBox + end interface amg_PMatchBox - interface psb_htranspose - module procedure psb_shtranspose - end interface psb_htranspose - - interface PMatchBox - module procedure sPMatchBox - end interface PMatchBox - - logical, parameter, private :: print_statistics=.false. contains - subroutine smatchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,& + subroutine amg_s_matchboxp_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,& & symmetrize,reproducible,display_inp, display_out, print_out) use psb_base_mod use psb_util_mod @@ -214,7 +205,7 @@ contains end if if (do_timings) call psb_toc(idx_phase1) if (do_timings) call psb_tic(idx_bldmtc) - call build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize) + call amg_par_build_matching(w,a,desc_a,mate,info,display_inp=display_inp,symmetrize=symmetrize) if (do_timings) call psb_toc(idx_bldmtc) if (debug) write(0,*) iam,' buildprol from buildmatching:',& & info @@ -312,7 +303,7 @@ contains ! Should be a symmetric function. ! call desc_a%indxmap%qry_halo_owner(idx,iown,info) - ip = i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) + ip = amg_i_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) if (iam == ip) then nlaggr(iam) = nlaggr(iam) + 1 ilaggr(k) = nlaggr(iam) @@ -422,13 +413,11 @@ contains nlpairs = v(3) end block - if (print_statistics) then - if (iam == 0) then - write(0,*) 'Matching statistics: Unmatched nodes ',& - & nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs - end if + if (iam == 0) then + write(0,*) 'Matching statistics: Unmatched nodes ',& + & nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs end if - + if (display_out_) then block integer(psb_ipk_) :: idx @@ -516,9 +505,9 @@ contains write(0,*) iam,' : error from Matching: ',info end if - end subroutine smatchboxp_build_prol + end subroutine amg_s_matchboxp_build_prol - function i_saggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) & + function amg_i_s_aggr_assign(iam, iown, kg, idxg, wk, widx, nrmagg) & & result(iproc) ! ! How to break ties? This @@ -560,10 +549,10 @@ contains iproc = iown end if end if - end function i_saggr_assign + end function amg_i_s_aggr_assign - subroutine sbuild_matching(w,a,desc_a,mate,info,display_inp, symmetrize) + subroutine amg_s_par_build_matching(w,a,desc_a,mate,info,display_inp, symmetrize) use psb_base_mod use psb_util_mod use iso_c_binding @@ -612,7 +601,7 @@ contains if (iam == 0) write(0,*)' Into build_ahat:' end if if (do_timings) call psb_tic(idx_bldahat) - call build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize) + call amg_par_build_ahat(w,a,ahatnd,desc_a,info,symmetrize=symmetrize) if (do_timings) call psb_toc(idx_bldahat) if (info /= 0) then write(0,*) 'Error from build_ahat ', info @@ -703,7 +692,7 @@ contains ! if (debug) write(0,*) iam,' buildmatching into PMatchBox:' if (do_timings) call psb_tic(idx_cmboxp) - call PMatchBox(nr,nz,vlptr,vlind,ewght,& + call amg_PMatchBox(nr,nz,vlptr,vlind,ewght,& & vnl, mate, iam, np,ictxt,& & msgis,msgas,msgprc,ph0t,ph1t,ph2t,ph1crd,ph2crd,info,display_inp) if (do_timings) call psb_toc(idx_cmboxp) @@ -767,9 +756,9 @@ contains val(1:n) = tmp(1:n) end subroutine fix_order - end subroutine sbuild_matching + end subroutine amg_s_par_build_matching - subroutine sbuild_ahat(w,a,ahat,desc_a,info,symmetrize) + subroutine amg_s_par_build_ahat(w,a,ahat,desc_a,info,symmetrize) use psb_base_mod implicit none real(psb_spk_), intent(in) :: w(:) @@ -1005,301 +994,9 @@ contains end block end if - end subroutine sbuild_ahat + end subroutine amg_s_par_build_ahat - subroutine psb_sgtranspose(ain,aout,desc_a,info) - use psb_base_mod - implicit none - type(psb_lsspmat_type), intent(in) :: ain - type(psb_lsspmat_type), intent(out) :: aout - type(psb_desc_type) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! - ! BEWARE: This routine works under the assumption - ! that the same DESC_A works for both A and A^T, which - ! essentially means that A has a symmetric pattern. - ! - type(psb_lsspmat_type) :: atmp, ahalo, aglb - type(psb_ls_coo_sparse_mat) :: tmpcoo - type(psb_ls_csr_sparse_mat) :: tmpcsr - type(psb_ctxt_type) :: ictxt - integer(psb_ipk_) :: me, np - integer(psb_lpk_) :: i, j, k, nrow, ncol - integer(psb_lpk_), allocatable :: ilv(:) - character(len=80) :: aname - logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'Start gtranspose ' - end if - call ain%cscnv(tmpcsr,info) - - if (debug) then - ilv = [(i,i=1,ncol)] - call desc_a%l2gip(ilv,info,owned=.false.) - write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx' - call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv) - end if - if (dump) then - call ain%cscnv(atmp,info) - call psb_gather(aglb,atmp,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - !call psb_loc_to_glob(tmpcsr%ja,desc_a,info) - call atmp%mv_from(tmpcsr) - - if (debug) then - write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx' - call atmp%print(fname=aname,head='tmpcsr ',iv=ilv) - !call psb_set_debug_level(9999) - end if - - ! FIXME THIS NEEDS REWORKING - if (debug) write(0,*) me,' Gtranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols() - call psb_sphalo(atmp,desc_a,ahalo,info,rowscale=.true.) - if (debug) write(0,*) me,' Gtranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols() - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo) - - if (debug) then - write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx' - call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv) - write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx' - call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv) - end if - - if (info == psb_success_) call ahalo%free() - - call atmp%cp_to(tmpcoo) - call tmpcoo%transp() - !call psb_glob_to_loc(tmpcoo%ia,desc_a,info,iact='I') - if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros() - - j = 0 - do k=1, tmpcoo%get_nzeros() - if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then - j = j+1 - tmpcoo%ia(j) = tmpcoo%ia(k) - tmpcoo%ja(j) = tmpcoo%ja(k) - tmpcoo%val(j) = tmpcoo%val(k) - end if - end do - call tmpcoo%set_nzeros(j) - - if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros() - - call ahalo%mv_from(tmpcoo) - if (dump) then - call psb_gather(aglb,ahalo,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran-preclip.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - - call ahalo%csclip(aout,info,imax=nrow) - - if (debug) write(0,*) 'After clip:',aout%get_nzeros() - - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'End gtranspose ' - end if - !call aout%cscnv(info,type='csr') - - if (dump) then - write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx' - call aout%print(fname=aname,head='atrans ',iv=ilv) - call psb_gather(aglb,aout,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - end subroutine psb_sgtranspose - - subroutine psb_shtranspose(ain,aout,desc_a,info) - use psb_base_mod - implicit none - type(psb_lsspmat_type), intent(in) :: ain - type(psb_lsspmat_type), intent(out) :: aout - type(psb_desc_type) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! - ! BEWARE: This routine works under the assumption - ! that the same DESC_A works for both A and A^T, which - ! essentially means that A has a symmetric pattern. - ! - type(psb_lsspmat_type) :: atmp, ahalo, aglb - type(psb_ls_coo_sparse_mat) :: tmpcoo, tmpc1, tmpc2, tmpch - type(psb_ls_csr_sparse_mat) :: tmpcsr - integer(psb_ipk_) :: nz1, nz2, nzh, nz - type(psb_ctxt_type) :: ictxt - integer(psb_ipk_) :: me, np - integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz - integer(psb_lpk_), allocatable :: ilv(:) - character(len=80) :: aname - logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'Start htranspose ' - end if - call ain%cscnv(tmpcsr,info) - - if (debug) then - ilv = [(i,i=1,ncol)] - call desc_a%l2gip(ilv,info,owned=.false.) - write(aname,'(a,i3.3,a)') 'atmp-preh-',me,'.mtx' - call ain%print(fname=aname,head='atmp before haloTest ',iv=ilv) - end if - if (dump) then - call ain%cscnv(atmp,info) - call psb_gather(aglb,atmp,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'aglob-prehalo.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - !call psb_loc_to_glob(tmpcsr%ja,desc_a,info) - call atmp%mv_from(tmpcsr) - - if (debug) then - write(aname,'(a,i3.3,a)') 'tmpcsr-',me,'.mtx' - call atmp%print(fname=aname,head='tmpcsr ',iv=ilv) - !call psb_set_debug_level(9999) - end if - - ! FIXME THIS NEEDS REWORKING - if (debug) write(0,*) me,' Htranspose into sphalo :',atmp%get_nrows(),atmp%get_ncols() - if (.true.) then - call psb_sphalo(atmp,desc_a,ahalo,info, outfmt='coo ') - call atmp%mv_to(tmpc1) - call ahalo%mv_to(tmpch) - nz1 = tmpc1%get_nzeros() - call psb_loc_to_glob(tmpc1%ia(1:nz1),desc_a,info,iact='I') - call psb_loc_to_glob(tmpc1%ja(1:nz1),desc_a,info,iact='I') - nzh = tmpch%get_nzeros() - call psb_loc_to_glob(tmpch%ia(1:nzh),desc_a,info,iact='I') - call psb_loc_to_glob(tmpch%ja(1:nzh),desc_a,info,iact='I') - nlz = nz1+nzh - call tmpcoo%allocate(ncol,ncol,nlz) - tmpcoo%ia(1:nz1) = tmpc1%ia(1:nz1) - tmpcoo%ja(1:nz1) = tmpc1%ja(1:nz1) - tmpcoo%val(1:nz1) = tmpc1%val(1:nz1) - tmpcoo%ia(nz1+1:nz1+nzh) = tmpch%ia(1:nzh) - tmpcoo%ja(nz1+1:nz1+nzh) = tmpch%ja(1:nzh) - tmpcoo%val(nz1+1:nz1+nzh) = tmpch%val(1:nzh) - call tmpcoo%set_nzeros(nlz) - call tmpcoo%transp() - nz = tmpcoo%get_nzeros() - call psb_glob_to_loc(tmpcoo%ia(1:nz),desc_a,info,iact='I') - call psb_glob_to_loc(tmpcoo%ja(1:nz),desc_a,info,iact='I') - if (.true.) then - call tmpcoo%clean_negidx(info) - else - j = 0 - do k=1, tmpcoo%get_nzeros() - if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then - j = j+1 - tmpcoo%ia(j) = tmpcoo%ia(k) - tmpcoo%ja(j) = tmpcoo%ja(k) - tmpcoo%val(j) = tmpcoo%val(k) - end if - end do - call tmpcoo%set_nzeros(j) - end if - call ahalo%mv_from(tmpcoo) - call ahalo%csclip(aout,info,imax=nrow) - - else - call psb_sphalo(atmp,desc_a,ahalo,info, rowscale=.true.) - if (debug) write(0,*) me,' Htranspose from sphalo :',ahalo%get_nrows(),ahalo%get_ncols() - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=ahalo) - - if (debug) then - write(aname,'(a,i3.3,a)') 'ahalo-',me,'.mtx' - call ahalo%print(fname=aname,head='ahalo after haloTest ',iv=ilv) - write(aname,'(a,i3.3,a)') 'atmp-h-',me,'.mtx' - call atmp%print(fname=aname,head='atmp after haloTest ',iv=ilv) - end if - - if (info == psb_success_) call ahalo%free() - - call atmp%cp_to(tmpcoo) - call tmpcoo%transp() - if (debug) write(0,*) 'Before cleanup:',tmpcoo%get_nzeros() - if (.true.) then - call tmpcoo%clean_negidx(info) - else - - j = 0 - do k=1, tmpcoo%get_nzeros() - if ((tmpcoo%ia(k) > 0).and.(tmpcoo%ja(k)>0)) then - j = j+1 - tmpcoo%ia(j) = tmpcoo%ia(k) - tmpcoo%ja(j) = tmpcoo%ja(k) - tmpcoo%val(j) = tmpcoo%val(k) - end if - end do - call tmpcoo%set_nzeros(j) - end if - - if (debug) write(0,*) 'After cleanup:',tmpcoo%get_nzeros() - - call ahalo%mv_from(tmpcoo) - if (dump) then - call psb_gather(aglb,ahalo,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran-preclip.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - - call ahalo%csclip(aout,info,imax=nrow) - end if - - if (debug) write(0,*) 'After clip:',aout%get_nzeros() - - if (debug_sync) then - call psb_barrier(ictxt) - if (me == 0) write(0,*) 'End htranspose ' - end if - !call aout%cscnv(info,type='csr') - - if (dump) then - write(aname,'(a,i3.3,a)') 'atran-',me,'.mtx' - call aout%print(fname=aname,head='atrans ',iv=ilv) - call psb_gather(aglb,aout,desc_a,info) - if (me==psb_root_) then - write(aname,'(a,i3.3,a)') 'atran.mtx' - call aglb%print(fname=aname,head='Test ') - end if - end if - - end subroutine psb_shtranspose - - subroutine sPMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,& + subroutine amg_s_PMatchBox(nlver,nledge,verlocptr,verlocind,edgelocweight,& & verdistance, mate, myrank, numprocs, ictxt,& & msgindsent,msgactualsent,msgpercent,& & ph0_time, ph1_time, ph2_time, ph1_card, ph2_card,info,display_inp) @@ -1434,6 +1131,6 @@ contains end if where(mate>=0) mate = mate + 1 - end subroutine sPMatchBox + end subroutine amg_s_PMatchBox -end module smatchboxp_mod +end module amg_s_matchboxp_mod diff --git a/amgprec/amg_s_parmatch_aggregator_mod.F90 b/amgprec/amg_s_parmatch_aggregator_mod.F90 index 32a3b711..d5b3b04f 100644 --- a/amgprec/amg_s_parmatch_aggregator_mod.F90 +++ b/amgprec/amg_s_parmatch_aggregator_mod.F90 @@ -118,7 +118,7 @@ module amg_s_parmatch_aggregator_mod use amg_s_base_aggregator_mod - use smatchboxp_mod + use amg_s_matchboxp_mod #if defined(SERIAL_MPI) type, extends(amg_s_base_aggregator_type) :: amg_s_parmatch_aggregator_type end type amg_s_parmatch_aggregator_type @@ -132,8 +132,6 @@ module amg_s_parmatch_aggregator_mod type(psb_sspmat_type), allocatable :: prol, restr type(psb_sspmat_type), allocatable :: ac, base_a, rwa type(psb_desc_type), allocatable :: desc_ac, desc_ax, base_desc, rwdesc - integer(psb_ipk_) :: max_csize - integer(psb_ipk_) :: max_nlevels logical :: reproducible_matching = .false. logical :: need_symmetrize = .false. logical :: unsmoothed_hierarchy = .true. @@ -143,18 +141,18 @@ module amg_s_parmatch_aggregator_mod procedure, pass(ag) :: mat_asb => amg_s_parmatch_aggregator_mat_asb procedure, pass(ag) :: inner_mat_asb => amg_s_parmatch_aggregator_inner_mat_asb procedure, pass(ag) :: bld_map => amg_s_parmatch_aggregator_bld_map - procedure, pass(ag) :: csetc => s_parmatch_aggr_csetc - procedure, pass(ag) :: cseti => s_parmatch_aggr_cseti - procedure, pass(ag) :: default => s_parmatch_aggr_set_default - procedure, pass(ag) :: sizeof => s_parmatch_aggregator_sizeof - procedure, pass(ag) :: update_next => s_parmatch_aggregator_update_next - procedure, pass(ag) :: bld_wnxt => s_parmatch_bld_wnxt - procedure, pass(ag) :: bld_default_w => s_bld_default_w - procedure, pass(ag) :: set_c_default_w => s_set_prm_c_default_w - procedure, pass(ag) :: descr => s_parmatch_aggregator_descr - procedure, pass(ag) :: clone => s_parmatch_aggregator_clone - procedure, pass(ag) :: free => s_parmatch_aggregator_free - procedure, nopass :: fmt => s_parmatch_aggregator_fmt + procedure, pass(ag) :: csetc => amg_s_parmatch_aggr_csetc + procedure, pass(ag) :: cseti => amg_s_parmatch_aggr_cseti + procedure, pass(ag) :: default => amg_s_parmatch_aggr_set_default + procedure, pass(ag) :: sizeof => amg_s_parmatch_aggregator_sizeof + procedure, pass(ag) :: update_next => amg_s_parmatch_aggregator_update_next + procedure, pass(ag) :: bld_wnxt => amg_s_parmatch_bld_wnxt + procedure, pass(ag) :: bld_default_w => amg_s_bld_default_w + procedure, pass(ag) :: set_c_default_w => amg_s_set_prm_c_default_w + procedure, pass(ag) :: descr => amg_s_parmatch_aggregator_descr + procedure, pass(ag) :: clone => amg_s_parmatch_aggregator_clone + procedure, pass(ag) :: free => amg_s_parmatch_aggregator_free + procedure, nopass :: fmt => amg_s_parmatch_aggregator_fmt procedure, nopass :: xt_desc => amg_s_parmatch_aggregator_xt_desc end type amg_s_parmatch_aggregator_type @@ -168,7 +166,7 @@ module amg_s_parmatch_aggregator_mod type(amg_sml_parms), intent(inout) :: parms type(amg_saggr_data), intent(in) :: ag_data type(psb_sspmat_type), intent(inout) :: a - type(psb_desc_type), intent(inout) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lsspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info @@ -235,7 +233,7 @@ module amg_s_parmatch_aggregator_mod & psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data implicit none type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol @@ -257,7 +255,7 @@ module amg_s_parmatch_aggregator_mod integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol - type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_s_parmatch_unsmth_bld @@ -275,7 +273,7 @@ module amg_s_parmatch_aggregator_mod integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol - type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_s_parmatch_smth_bld @@ -288,11 +286,11 @@ module amg_s_parmatch_aggregator_mod & psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data implicit none type(psb_sspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol - type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(out) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_s_parmatch_spmm_bld_ov @@ -306,11 +304,11 @@ module amg_s_parmatch_aggregator_mod & psb_s_csr_sparse_mat, psb_ls_csr_sparse_mat implicit none type(psb_s_csr_sparse_mat), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol - type(psb_sspmat_type), intent(out) :: op_prol,ac, op_restr + type(psb_sspmat_type), intent(inout) :: op_prol,ac, op_restr type(psb_desc_type), intent(out) :: desc_ac integer(psb_ipk_), intent(out) :: info end subroutine amg_s_parmatch_spmm_bld_inner @@ -320,7 +318,7 @@ module amg_s_parmatch_aggregator_mod contains - subroutine s_bld_default_w(ag,nr) + subroutine amg_s_bld_default_w(ag,nr) use psb_realloc_mod implicit none class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag @@ -330,9 +328,9 @@ contains if (info /= psb_success_) return ag%w = done !call ag%set_c_default_w() - end subroutine s_bld_default_w + end subroutine amg_s_bld_default_w - subroutine s_set_prm_c_default_w(ag) + subroutine amg_s_set_prm_c_default_w(ag) use psb_realloc_mod use iso_c_binding implicit none @@ -342,9 +340,9 @@ contains !write(0,*) 'prm_c_deafult_w ' call psb_safe_ab_cpy(ag%w,ag%w_nxt,info) - end subroutine s_set_prm_c_default_w + end subroutine amg_s_set_prm_c_default_w - subroutine s_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx) + subroutine amg_s_parmatch_bld_wnxt(ag,ilaggr,valaggr,nx) use psb_realloc_mod implicit none class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag @@ -358,14 +356,14 @@ contains !write(0,*) 'Executing bld_wnxt ',nx call psb_realloc(nx,ag%w_nxt,info) - end subroutine s_parmatch_bld_wnxt + end subroutine amg_s_parmatch_bld_wnxt - function s_parmatch_aggregator_fmt() result(val) + function amg_s_parmatch_aggregator_fmt() result(val) implicit none character(len=32) :: val val = "Parallel Matching aggregation" - end function s_parmatch_aggregator_fmt + end function amg_s_parmatch_aggregator_fmt function amg_s_parmatch_aggregator_xt_desc() result(val) implicit none @@ -374,7 +372,7 @@ contains val = .true. end function amg_s_parmatch_aggregator_xt_desc - function s_parmatch_aggregator_sizeof(ag) result(val) + function amg_s_parmatch_aggregator_sizeof(ag) result(val) use psb_realloc_mod implicit none class(amg_s_parmatch_aggregator_type), intent(in) :: ag @@ -390,9 +388,9 @@ contains if (allocated(ag%base_desc)) val = val + ag%base_desc%sizeof() if (allocated(ag%desc_ax)) val = val + ag%desc_ax%sizeof() - end function s_parmatch_aggregator_sizeof + end function amg_s_parmatch_aggregator_sizeof - subroutine s_parmatch_aggregator_descr(ag,parms,iout,info) + subroutine amg_s_parmatch_aggregator_descr(ag,parms,iout,info) implicit none class(amg_s_parmatch_aggregator_type), intent(in) :: ag type(amg_sml_parms), intent(in) :: parms @@ -406,7 +404,7 @@ contains call parms%mldescr(iout,info) return - end subroutine s_parmatch_aggregator_descr + end subroutine amg_s_parmatch_aggregator_descr function is_legal_malg(alg) result(val) logical :: val @@ -437,7 +435,7 @@ contains end function is_legal_nlevels - subroutine s_parmatch_aggregator_update_next(ag,agnext,info) + subroutine amg_s_parmatch_aggregator_update_next(ag,agnext,info) use psb_realloc_mod implicit none class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag @@ -452,10 +450,10 @@ contains & agnext%matching_alg = ag%matching_alg if (.not.is_legal_nsweeps(agnext%n_sweeps))& & agnext%n_sweeps = ag%n_sweeps - if (.not.is_legal_csize(agnext%max_csize))& - & agnext%max_csize = ag%max_csize - if (.not.is_legal_nlevels(agnext%max_nlevels))& - & agnext%max_nlevels = ag%max_nlevels +!!$ if (.not.is_legal_csize(agnext%max_csize))& +!!$ & agnext%max_csize = ag%max_csize +!!$ if (.not.is_legal_nlevels(agnext%max_nlevels))& +!!$ & agnext%max_nlevels = ag%max_nlevels ! Is this going to generate shallow copies/memory leaks/double frees? ! To be investigated further. call psb_safe_ab_cpy(ag%w_nxt,agnext%w,info) @@ -470,9 +468,9 @@ contains ! What should we do here? end select info = 0 - end subroutine s_parmatch_aggregator_update_next + end subroutine amg_s_parmatch_aggregator_update_next - subroutine s_parmatch_aggr_csetc(ag,what,val,info,idx) + subroutine amg_s_parmatch_aggr_csetc(ag,what,val,info,idx) Implicit None @@ -514,9 +512,9 @@ contains ! Do nothing end select return - end subroutine s_parmatch_aggr_csetc + end subroutine amg_s_parmatch_aggr_csetc - subroutine s_parmatch_aggr_cseti(ag,what,val,info,idx) + subroutine amg_s_parmatch_aggr_cseti(ag,what,val,info,idx) Implicit None @@ -540,10 +538,6 @@ contains case('AGGR_SIZE') ag%orig_aggr_size = val ag%n_sweeps=max(1,ceiling(log(val*1.0)/log(2.0))) - case('PRMC_MAX_CSIZE') - ag%max_csize=val - case('PRMC_MAX_NLEVELS') - ag%max_nlevels=val case('PRMC_W_SIZE') call ag%bld_default_w(val) case('PRMC_REPRODUCIBLE_MATCHING') @@ -556,9 +550,9 @@ contains ! Do nothing end select return - end subroutine s_parmatch_aggr_cseti + end subroutine amg_s_parmatch_aggr_cseti - subroutine s_parmatch_aggr_set_default(ag) + subroutine amg_s_parmatch_aggr_set_default(ag) Implicit None @@ -569,8 +563,8 @@ contains ag%matching_alg = 0 ag%n_sweeps = 1 ag%jacobi_sweeps = 0 - ag%max_nlevels = 36 - ag%max_csize = -1 +!!$ ag%max_nlevels = 36 +!!$ ag%max_csize = -1 ! ! Apparently BootCMatch works better ! by keeping all entries @@ -579,9 +573,9 @@ contains return - end subroutine s_parmatch_aggr_set_default + end subroutine amg_s_parmatch_aggr_set_default - subroutine s_parmatch_aggregator_free(ag,info) + subroutine amg_s_parmatch_aggregator_free(ag,info) use iso_c_binding implicit none class(amg_s_parmatch_aggregator_type), intent(inout) :: ag @@ -618,9 +612,9 @@ contains call ag%rwdesc%free(info); deallocate(ag%rwdesc,stat=info) end if - end subroutine s_parmatch_aggregator_free + end subroutine amg_s_parmatch_aggregator_free - subroutine s_parmatch_aggregator_clone(ag,agnext,info) + subroutine amg_s_parmatch_aggregator_clone(ag,agnext,info) implicit none class(amg_s_parmatch_aggregator_type), intent(inout) :: ag class(amg_s_base_aggregator_type), allocatable, intent(inout) :: agnext @@ -640,7 +634,7 @@ contains ! Should never ever get here info = -1 end select - end subroutine s_parmatch_aggregator_clone + end subroutine amg_s_parmatch_aggregator_clone subroutine amg_s_parmatch_aggregator_bld_map(ag,desc_a,desc_ac,ilaggr,nlaggr,& & op_restr,op_prol,map,info) diff --git a/amgprec/amg_z_base_aggregator_mod.f90 b/amgprec/amg_z_base_aggregator_mod.f90 index 84c52a9d..81858fb7 100644 --- a/amgprec/amg_z_base_aggregator_mod.f90 +++ b/amgprec/amg_z_base_aggregator_mod.f90 @@ -126,7 +126,7 @@ module amg_z_base_aggregator_mod & psb_z_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_ implicit none type(psb_z_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_z_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr @@ -144,7 +144,7 @@ module amg_z_base_aggregator_mod & psb_z_coo_sparse_mat, amg_dml_parms, psb_dpk_, psb_ipk_, psb_lpk_ implicit none type(psb_z_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_z_coo_sparse_mat), intent(inout) :: coo_prol, coo_restr diff --git a/amgprec/amg_z_sludist_solver.F90 b/amgprec/amg_z_sludist_solver.F90 index 50cd39b4..1414353c 100644 --- a/amgprec/amg_z_sludist_solver.F90 +++ b/amgprec/amg_z_sludist_solver.F90 @@ -52,7 +52,7 @@ module amg_z_sludist_solver use iso_c_binding use amg_z_base_solver_mod -#if defined(LPK8) +#if (!defined(HAVE_SLUDIST_)) || defined(IPK8) type, extends(amg_z_base_solver_type) :: amg_z_sludist_solver_type @@ -270,11 +270,13 @@ contains ! Local variables type(psb_zspmat_type) :: atmp type(psb_z_csr_sparse_mat) :: acsr - integer :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc - integer :: ifrst, ibcheck + integer(psb_lpk_), allocatable :: gia(:), gja(:) type(psb_ctxt_type) :: ctxt - integer :: np,me,i, err_act, debug_unit, debug_level - character(len=20) :: name='z_sludist_solver_bld', ch_err + integer(psb_lpk_) :: lfrst + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nzt, npr, npc + integer(psb_ipk_) :: ifrst, ibcheck + integer(psb_ipk_) :: np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='z_sludist_solver_bld', ch_err info=psb_success_ call psb_erractionsave(err_act) @@ -293,19 +295,36 @@ contains n_col = desc_a%get_local_cols() nglob = desc_a%get_global_rows() - call a%cscnv(atmp,info,type='coo') + ! + ! Strategy here is as follows: because a call to SLUDIST + ! as a gobal solver is mostly done at the coarsest level, + ! even if we start from a problem requiring 8 bytes, chances + ! are that the global size will be suitable for 4 bytes + ! anyway, so we hope for the best, and throw an error + ! if something goes wrong. + ! + if (nglob > huge(1_psb_ipk_)) then + write(0,*) me,' ',trim(name),': Error: overflow of local indices ' + info=psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%cscnv(atmp,info,type='csr') + ! This in case we are dealing with AS call psb_rwextd(n_row,atmp,info,b=b) - call atmp%cscnv(info,type='csr',dupl=psb_dupl_add_) call atmp%mv_to(acsr) nrow_a = acsr%get_nrows() nztota = acsr%get_nzeros() + call psb_loc_to_glob(ione,lfrst,desc_a,info) + ! Fix the entries to call C-base SuperLU - call psb_loc_to_glob(1,ifrst,desc_a,info) - call psb_loc_to_glob(nrow_a,ibcheck,desc_a,info) - call psb_loc_to_glob(acsr%ja(1:nztota),desc_a,info,iact='I') + call psb_realloc(nztota,gja,info) + call psb_loc_to_glob(acsr%ja(1:nztota),gja(1:nztota), desc_a, info, iact='I') + acsr%ja(1:nztota) = gja(1:nztota) acsr%ja(:) = acsr%ja(:) - 1 acsr%irp(:) = acsr%irp(:) - 1 - ifrst = ifrst - 1 + ifrst = lfrst - 1 info = amg_zsludist_fact(nglob,nrow_a,nztota,ifrst,& & acsr%val,acsr%irp,acsr%ja,sv%lufactors,& & npr,npc) @@ -318,7 +337,6 @@ contains end if call acsr%free() - call atmp%free() if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),' end' diff --git a/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 index cb8fb6a7..4efaf61d 100644 --- a/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 @@ -83,8 +83,8 @@ subroutine amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_c_dec_aggregator_type), target, intent(inout) :: ag type(amg_sml_parms), intent(inout) :: parms type(amg_saggr_data), intent(in) :: ag_data - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lcspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_c_symdec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_c_symdec_aggregator_tprol.f90 index 9974a233..4a71212e 100644 --- a/amgprec/impl/aggregator/amg_c_symdec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_c_symdec_aggregator_tprol.f90 @@ -86,8 +86,8 @@ subroutine amg_c_symdec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_c_symdec_aggregator_type), target, intent(inout) :: ag type(amg_sml_parms), intent(inout) :: parms type(amg_saggr_data), intent(in) :: ag_data - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lcspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_caggrmat_minnrg_bld.f90 b/amgprec/impl/aggregator/amg_caggrmat_minnrg_bld.f90 index e14001c6..612c2953 100644 --- a/amgprec/impl/aggregator/amg_caggrmat_minnrg_bld.f90 +++ b/amgprec/impl/aggregator/amg_caggrmat_minnrg_bld.f90 @@ -105,7 +105,7 @@ ! ! subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& - & ac,desc_ac,op_prol,op_restr,info) + & ac,desc_ac,op_prol,op_restr,t_prol,info) use psb_base_mod use amg_base_prec_type use amg_c_inner_mod, amg_protect_name => amg_caggrmat_minnrg_bld @@ -117,8 +117,8 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms - type(psb_lcspmat_type), intent(inout) :: op_prol - type(psb_lcspmat_type), intent(out) :: ac,op_restr + type(psb_lcspmat_type), intent(inout) :: t_prol + type(psb_cspmat_type), intent(inout) :: op_prol, ac,op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info @@ -171,6 +171,8 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& filter_mat = (parms%aggr_filter == amg_filter_mat_) + !NEEDS TO BE REWORKED !! + ! naggr: number of local aggregates ! nrow: local rows. ! @@ -183,361 +185,361 @@ subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& goto 9999 end if - ! Get the diagonal D - adiag = a%get_diag(info) - if (info == psb_success_) & - & call psb_realloc(ncol,adiag,info) - if (info == psb_success_) & - & call psb_halo(adiag,desc_a,info) - if (info == psb_success_) call a%cp_to_l(la) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') - goto 9999 - end if - - do i=1,size(adiag) - if (adiag(i) /= czero) then - adinv(i) = cone / adiag(i) - else - adinv(i) = cone - end if - end do - - - - ! 1. Allocate Ptilde in sparse matrix form - call op_prol%mv_to(tmpcoo) - call ptilde%mv_from(tmpcoo) - call ptilde%cscnv(info,type='csr') - - if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Initial copies done.' - - call da%scal(adinv,info) - - call psb_spspmm(da,ptilde,dap,info) - - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') - goto 9999 - end if - - call dap%clone(atmp,info) - - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) - if (info == psb_success_) call am4%free() - - call psb_spspmm(da,atmp,dadap,info) - call atmp%free() - - ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) - ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) - call dap%mv_to(csc_dap) - call dadap%mv_to(csc_dadap) - - call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) - call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - ! !$ write(0,*) trim(name),' OMP :',omp - ! !$ write(0,*) trim(name),' ODEN:',oden - - omp = omp/oden - - ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - call am3%mv_to(acsr3) - ! Compute omega_int - ommx = czero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = czero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - do i=1, nrow - omf(i) = ommx - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero - if(psb_minreal(omf(i)) < szero) omf(i) = czero - end do - - omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) - - if (filter_mat) then - ! - ! Build the filtered matrix Af from A - ! - call la%cscnv(acsrf,info,dupl=psb_dupl_add_) - - do i=1,nrow - tmp = czero - jd = -1 - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) jd = j - if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then - tmp=tmp+acsrf%val(j) - acsrf%val(j)=czero - endif - enddo - if (jd == -1) then - write(0,*) 'Wrong input: we need the diagonal!!!!', i - else - acsrf%val(jd)=acsrf%val(jd)-tmp - end if - enddo - ! Take out zeroed terms - call acsrf%clean_zeros(info) - - ! - ! Build the smoothed prolongator using the filtered matrix - ! - do i=1,acsrf%get_nrows() - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) then - acsrf%val(j) = cone - omf(i)*acsrf%val(j) - else - acsrf%val(j) = - omf(i)*acsrf%val(j) - end if - end do - end do - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - - call af%mv_from(acsrf) - ! - ! op_prol = (I-w*D*Af)Ptilde - ! Doing it this way means to consider diag(Af_i) - ! - ! - call psb_spspmm(af,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 1' - else - ! - ! Build the smoothed prolongator using the original matrix - ! - do i=1,acsr3%get_nrows() - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) == i) then - acsr3%val(j) = cone - omf(i)*acsr3%val(j) - else - acsr3%val(j) = - omf(i)*acsr3%val(j) - end if - end do - end do - - call am3%mv_from(acsr3) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - ! - ! - ! op_prol = (I-w*D*A)Ptilde - ! - ! - call psb_spspmm(am3,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - end if - - - ! - ! Ok, let's start over with the restrictor - ! - call ptilde%transc(rtilde) - call la%cscnv(atmp,info,type='csr') - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.true.,rowscale=.true.) - nrt = am4%get_nrows() - call am4%csclip(atmp2,info,lone,nrt,lone,ncol) - call atmp2%cscnv(info,type='CSR') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) - call am4%free() - call atmp2%free() - - ! This is to compute the transpose. It ONLY works if the - ! original A has a symmetric pattern. - call atmp%transc(atmp2) - call atmp2%csclip(dat,info,lone,nrow,lone,ncol) - call dat%cscnv(info,type='csr') - call dat%scal(adinv,info) - - ! Now for the product. - call psb_spspmm(dat,ptilde,datp,info) - - call datp%clone(atmp2,info) - call psb_sphalo(atmp2,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) - if (info == psb_success_) call am4%free() - - - call psb_symbmm(dat,atmp2,datdatp,info) - call psb_numbmm(dat,atmp2,datdatp) - call atmp2%free() - - call datp%mv_to(csc_datp) - call datdatp%mv_to(csc_datdatp) - - call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) - call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - - - ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp - ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden - omp = omp/oden - ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) - ! Compute omega_int - ommx = czero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = czero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - ! Going over the columns of atmp means going over the rows - ! of A^T. Hopefully ;-) - call atmp%cp_to(acsc) - - do i=1, nrow - omf(i) = ommx - do j= acsc%icp(i),acsc%icp(i+1)-1 - if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero - if(psb_minreal(omf(i)) < szero) omf(i) = czero - end do - omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) - call psb_halo(omf,desc_a,info) - call acsc%free() - - - call atmp%mv_to(acsr1) - - do i=1,acsr1%get_nrows() - do j=acsr1%irp(i),acsr1%irp(i+1)-1 - if (acsr1%ja(j) == i) then - acsr1%val(j) = cone - acsr1%val(j)*omf(acsr1%ja(j)) - else - acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) - end if - end do - end do - call atmp%mv_from(acsr1) - - call rtilde%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call rtilde%mv_from(tmpcoo) - call rtilde%cscnv(info,type='csr') - - call psb_spspmm(rtilde,atmp,op_restr,info) - - ! - ! Now we have to gather the halo of op_prol, and add it to itself - ! to multiply it by A, - ! - call op_prol%clone(tmp_prol,info) - if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') - goto 9999 - end if - - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - call op_restr%mv_to(tmpcoo) - - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - - call psb_spspmm(la,tmp_prol,am3,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 2' - - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Extend am3') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done sphalo/ rwxtd' - - call psb_spspmm(op_restr,am3,ac,info) - if (info == psb_success_) call am3%free() - if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build ac = op_restr x am3') - goto 9999 - end if +!!$ ! Get the diagonal D +!!$ adiag = a%get_diag(info) +!!$ if (info == psb_success_) & +!!$ & call psb_realloc(ncol,adiag,info) +!!$ if (info == psb_success_) & +!!$ & call psb_halo(adiag,desc_a,info) +!!$ if (info == psb_success_) call a%cp_to_l(la) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') +!!$ goto 9999 +!!$ end if +!!$ +!!$ do i=1,size(adiag) +!!$ if (adiag(i) /= czero) then +!!$ adinv(i) = cone / adiag(i) +!!$ else +!!$ adinv(i) = cone +!!$ end if +!!$ end do +!!$ +!!$ +!!$ +!!$ ! 1. Allocate Ptilde in sparse matrix form +!!$ call op_prol%mv_to(tmpcoo) +!!$ call ptilde%mv_from(tmpcoo) +!!$ call ptilde%cscnv(info,type='csr') +!!$ +!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & ' Initial copies done.' +!!$ +!!$ call da%scal(adinv,info) +!!$ +!!$ call psb_spspmm(da,ptilde,dap,info) +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call dap%clone(atmp,info) +!!$ +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ call psb_spspmm(da,atmp,dadap,info) +!!$ call atmp%free() +!!$ +!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) +!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) +!!$ call dap%mv_to(csc_dap) +!!$ call dadap%mv_to(csc_dadap) +!!$ +!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) +!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ ! !$ write(0,*) trim(name),' OMP :',omp +!!$ ! !$ write(0,*) trim(name),' ODEN:',oden +!!$ +!!$ omp = omp/oden +!!$ +!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ call am3%mv_to(acsr3) +!!$ ! Compute omega_int +!!$ ommx = czero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = czero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero +!!$ if(psb_minreal(omf(i)) < szero) omf(i) = czero +!!$ end do +!!$ +!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) +!!$ +!!$ if (filter_mat) then +!!$ ! +!!$ ! Build the filtered matrix Af from A +!!$ ! +!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_) +!!$ +!!$ do i=1,nrow +!!$ tmp = czero +!!$ jd = -1 +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) jd = j +!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then +!!$ tmp=tmp+acsrf%val(j) +!!$ acsrf%val(j)=czero +!!$ endif +!!$ enddo +!!$ if (jd == -1) then +!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i +!!$ else +!!$ acsrf%val(jd)=acsrf%val(jd)-tmp +!!$ end if +!!$ enddo +!!$ ! Take out zeroed terms +!!$ call acsrf%clean_zeros(info) +!!$ +!!$ ! +!!$ ! Build the smoothed prolongator using the filtered matrix +!!$ ! +!!$ do i=1,acsrf%get_nrows() +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) then +!!$ acsrf%val(j) = cone - omf(i)*acsrf%val(j) +!!$ else +!!$ acsrf%val(j) = - omf(i)*acsrf%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ +!!$ call af%mv_from(acsrf) +!!$ ! +!!$ ! op_prol = (I-w*D*Af)Ptilde +!!$ ! Doing it this way means to consider diag(Af_i) +!!$ ! +!!$ ! +!!$ call psb_spspmm(af,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 1' +!!$ else +!!$ ! +!!$ ! Build the smoothed prolongator using the original matrix +!!$ ! +!!$ do i=1,acsr3%get_nrows() +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if (acsr3%ja(j) == i) then +!!$ acsr3%val(j) = cone - omf(i)*acsr3%val(j) +!!$ else +!!$ acsr3%val(j) = - omf(i)*acsr3%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ call am3%mv_from(acsr3) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ ! +!!$ ! +!!$ ! op_prol = (I-w*D*A)Ptilde +!!$ ! +!!$ ! +!!$ call psb_spspmm(am3,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ end if +!!$ +!!$ +!!$ ! +!!$ ! Ok, let's start over with the restrictor +!!$ ! +!!$ call ptilde%transc(rtilde) +!!$ call la%cscnv(atmp,info,type='csr') +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.true.,rowscale=.true.) +!!$ nrt = am4%get_nrows() +!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol) +!!$ call atmp2%cscnv(info,type='CSR') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) +!!$ call am4%free() +!!$ call atmp2%free() +!!$ +!!$ ! This is to compute the transpose. It ONLY works if the +!!$ ! original A has a symmetric pattern. +!!$ call atmp%transc(atmp2) +!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol) +!!$ call dat%cscnv(info,type='csr') +!!$ call dat%scal(adinv,info) +!!$ +!!$ ! Now for the product. +!!$ call psb_spspmm(dat,ptilde,datp,info) +!!$ +!!$ call datp%clone(atmp2,info) +!!$ call psb_sphalo(atmp2,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ +!!$ call psb_symbmm(dat,atmp2,datdatp,info) +!!$ call psb_numbmm(dat,atmp2,datdatp) +!!$ call atmp2%free() +!!$ +!!$ call datp%mv_to(csc_datp) +!!$ call datdatp%mv_to(csc_datdatp) +!!$ +!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) +!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ +!!$ +!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp +!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden +!!$ omp = omp/oden +!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) +!!$ ! Compute omega_int +!!$ ommx = czero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = czero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ ! Going over the columns of atmp means going over the rows +!!$ ! of A^T. Hopefully ;-) +!!$ call atmp%cp_to(acsc) +!!$ +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j= acsc%icp(i),acsc%icp(i+1)-1 +!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = czero +!!$ if(psb_minreal(omf(i)) < szero) omf(i) = czero +!!$ end do +!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) +!!$ call psb_halo(omf,desc_a,info) +!!$ call acsc%free() +!!$ +!!$ +!!$ call atmp%mv_to(acsr1) +!!$ +!!$ do i=1,acsr1%get_nrows() +!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1 +!!$ if (acsr1%ja(j) == i) then +!!$ acsr1%val(j) = cone - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ else +!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ end if +!!$ end do +!!$ end do +!!$ call atmp%mv_from(acsr1) +!!$ +!!$ call rtilde%mv_to(tmpcoo) +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call rtilde%mv_from(tmpcoo) +!!$ call rtilde%cscnv(info,type='csr') +!!$ +!!$ call psb_spspmm(rtilde,atmp,op_restr,info) +!!$ +!!$ ! +!!$ ! Now we have to gather the halo of op_prol, and add it to itself +!!$ ! to multiply it by A, +!!$ ! +!!$ call op_prol%clone(tmp_prol,info) +!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') +!!$ goto 9999 +!!$ end if +!!$ +!!$ ! +!!$ ! Now we have to fix this. The only rows of B that are correct +!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) +!!$ ! +!!$ call op_restr%mv_to(tmpcoo) +!!$ +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call op_restr%mv_from(tmpcoo) +!!$ call op_restr%cscnv(info,type='csr') +!!$ +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'starting sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(la,tmp_prol,am3,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 2' +!!$ +!!$ call psb_sphalo(am3,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='Extend am3') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(op_restr,am3,ac,info) +!!$ if (info == psb_success_) call am3%free() +!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ &a_err='Build ac = op_restr x am3') +!!$ goto 9999 +!!$ end if diff --git a/amgprec/impl/aggregator/amg_caggrmat_smth_bld.f90 b/amgprec/impl/aggregator/amg_caggrmat_smth_bld.f90 index 03029f40..53e740fe 100644 --- a/amgprec/impl/aggregator/amg_caggrmat_smth_bld.f90 +++ b/amgprec/impl/aggregator/amg_caggrmat_smth_bld.f90 @@ -116,7 +116,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms - type(psb_cspmat_type), intent(out) :: op_prol,ac,op_restr + type(psb_cspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_lcspmat_type), intent(inout) :: t_prol type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 index e3d1e73c..2edcca6c 100644 --- a/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 @@ -83,8 +83,8 @@ subroutine amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_d_dec_aggregator_type), target, intent(inout) :: ag type(amg_dml_parms), intent(inout) :: parms type(amg_daggr_data), intent(in) :: ag_data - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_ldspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 b/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 index 8559fae0..f23869b7 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_aggregator_tprol.F90 @@ -48,7 +48,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& use amg_base_prec_type use amg_d_inner_mod #if defined(SERIAL_MPI) - use amg_d_parmatch_aggregator_mod + use amg_d_parmatch_aggregator_mod #else use amg_d_parmatch_aggregator_mod, amg_protect_name => amg_d_parmatch_aggregator_build_tprol #endif @@ -58,7 +58,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& type(amg_dml_parms), intent(inout) :: parms type(amg_daggr_data), intent(in) :: ag_data type(psb_dspmat_type), intent(inout) :: a - type(psb_desc_type), intent(inout) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_ldspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info @@ -68,7 +68,8 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& real(psb_dpk_), allocatable :: tmpw(:), tmpwnxt(:) integer(psb_lpk_), allocatable :: ixaggr(:), nxaggr(:), tlaggr(:), ivr(:) type(psb_dspmat_type) :: a_tmp - integer(c_int) :: match_algorithm, n_sweeps, max_csize, max_nlevels + integer(psb_ipk_) :: match_algorithm, n_sweeps + integer(psb_lpk_) :: target_csize character(len=40) :: name, ch_err character(len=80) :: fname, prefix_ type(psb_ctxt_type) :: ictxt @@ -128,27 +129,22 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& write(debug_unit, *) 'Warning: AGGR_SIZE reset to value ',2**n_sweeps end if end if - if (ag%max_csize > 0) then - max_csize = ag%max_csize + if (ag_data%target_coarse_size > 0) then + target_csize = ag_data%target_coarse_size else - max_csize = ag_data%min_coarse_size - end if - if (ag%max_nlevels > 0) then - max_nlevels = ag%max_nlevels - else - max_nlevels = ag_data%max_levs + target_csize = ag_data%min_coarse_size end if if (.true.) then block integer(psb_ipk_) :: ipv(2) - ipv(1) = max_csize + ipv(1) = target_csize ipv(2) = n_sweeps call psb_bcast(ictxt,ipv) - max_csize = ipv(1) + target_csize = ipv(1) n_sweeps = ipv(2) end block else - call psb_bcast(ictxt,max_csize) + call psb_bcast(ictxt,target_csize) call psb_bcast(ictxt,n_sweeps) end if if (n_sweeps /= ag%n_sweeps) then @@ -156,7 +152,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& end if !!$ if (me==0) write(0,*) 'Matching sweeps: ',n_sweeps n_sweeps = max(1,n_sweeps) - if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,max_csize + if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,target_csize if (ag%unsmoothed_hierarchy.and.allocated(ag%base_a)) then call ag%base_a%cp_to(acsr) if (ag%do_clean_zeros) call acsr%clean_zeros(info) @@ -242,7 +238,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& if (debug) then call psb_barrier(ictxt) - if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),max_csize + if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),target_csize end if ! @@ -264,7 +260,7 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& ! if (debug) write(0,*) me,' Into matchbox_build_prol ',info if (do_timings) call psb_tic(idx_mboxp) - call dmatchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,& + call amg_d_matchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,& & symmetrize=ag%need_symmetrize,reproducible=ag%reproducible_matching) if (do_timings) call psb_toc(idx_mboxp) if (debug) write(0,*) me,' Out from matchbox_build_prol ',info @@ -300,11 +296,11 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& if (debug) then call psb_barrier(ictxt) - if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),max_csize,info + if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),target_csize,info csz = sum(nxaggr) call psb_bcast(ictxt,csz) if (csz /= sum(nxaggr)) write(0,*) me,trim(name),' Mismatch matasb',& - & csz,sum(nxaggr),max_csize + & csz,sum(nxaggr),target_csize end if if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on entry to tmpwnxt 2' @@ -342,10 +338,10 @@ subroutine amg_d_parmatch_aggregator_build_tprol(ag,parms,ag_data,& call move_alloc(tmpwnxt,tmpw) if (debug) then if (csz /= sum(nlaggr)) write(0,*) me,trim(name),' Mismatch 2 matasb',& - & csz,sum(nlaggr),max_csize, info + & csz,sum(nlaggr),target_csize, info end if call acv(i-1)%free() - if ((sum(nlaggr) <= max_csize).or.(any(nlaggr==0))) then + if ((sum(nlaggr) <= target_csize).or.(any(nlaggr==0))) then x_sweeps = i exit sweeps_loop end if diff --git a/amgprec/impl/aggregator/amg_d_parmatch_smth_bld.F90 b/amgprec/impl/aggregator/amg_d_parmatch_smth_bld.F90 index 80022b73..2ad6388d 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_smth_bld.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_smth_bld.F90 @@ -122,7 +122,7 @@ subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,& integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol - type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr + type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld.F90 b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld.F90 index 0311f274..7faf408a 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld.F90 @@ -108,7 +108,7 @@ subroutine amg_d_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,& ! Arguments type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol diff --git a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 index a2917e83..04d89b2f 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_inner.F90 @@ -108,11 +108,11 @@ subroutine amg_d_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,& ! Arguments type(psb_d_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol - type(psb_dspmat_type), intent(out) :: ac, op_prol, op_restr + type(psb_dspmat_type), intent(inout) :: ac, op_prol, op_restr type(psb_desc_type), intent(out) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_ov.F90 b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_ov.F90 index 2b35c797..e3d3b262 100644 --- a/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_ov.F90 +++ b/amgprec/impl/aggregator/amg_d_parmatch_spmm_bld_ov.F90 @@ -108,7 +108,7 @@ subroutine amg_d_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,& ! Arguments type(psb_dspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms type(psb_ldspmat_type), intent(inout) :: t_prol diff --git a/amgprec/impl/aggregator/amg_d_symdec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_d_symdec_aggregator_tprol.f90 index 35efe63d..e4b2fd6e 100644 --- a/amgprec/impl/aggregator/amg_d_symdec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_d_symdec_aggregator_tprol.f90 @@ -86,8 +86,8 @@ subroutine amg_d_symdec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_d_symdec_aggregator_type), target, intent(inout) :: ag type(amg_dml_parms), intent(inout) :: parms type(amg_daggr_data), intent(in) :: ag_data - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_ldspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_daggrmat_minnrg_bld.f90 b/amgprec/impl/aggregator/amg_daggrmat_minnrg_bld.f90 index fc5728a6..f7b21847 100644 --- a/amgprec/impl/aggregator/amg_daggrmat_minnrg_bld.f90 +++ b/amgprec/impl/aggregator/amg_daggrmat_minnrg_bld.f90 @@ -105,7 +105,7 @@ ! ! subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& - & ac,desc_ac,op_prol,op_restr,info) + & ac,desc_ac,op_prol,op_restr,t_prol,info) use psb_base_mod use amg_base_prec_type use amg_d_inner_mod, amg_protect_name => amg_daggrmat_minnrg_bld @@ -117,8 +117,8 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms - type(psb_ldspmat_type), intent(inout) :: op_prol - type(psb_ldspmat_type), intent(out) :: ac,op_restr + type(psb_ldspmat_type), intent(inout) :: t_prol + type(psb_dspmat_type), intent(inout) :: op_prol, ac,op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info @@ -171,6 +171,8 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& filter_mat = (parms%aggr_filter == amg_filter_mat_) + !NEEDS TO BE REWORKED !! + ! naggr: number of local aggregates ! nrow: local rows. ! @@ -183,361 +185,361 @@ subroutine amg_daggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& goto 9999 end if - ! Get the diagonal D - adiag = a%get_diag(info) - if (info == psb_success_) & - & call psb_realloc(ncol,adiag,info) - if (info == psb_success_) & - & call psb_halo(adiag,desc_a,info) - if (info == psb_success_) call a%cp_to_l(la) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') - goto 9999 - end if - - do i=1,size(adiag) - if (adiag(i) /= dzero) then - adinv(i) = done / adiag(i) - else - adinv(i) = done - end if - end do - - - - ! 1. Allocate Ptilde in sparse matrix form - call op_prol%mv_to(tmpcoo) - call ptilde%mv_from(tmpcoo) - call ptilde%cscnv(info,type='csr') - - if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Initial copies done.' - - call da%scal(adinv,info) - - call psb_spspmm(da,ptilde,dap,info) - - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') - goto 9999 - end if - - call dap%clone(atmp,info) - - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) - if (info == psb_success_) call am4%free() - - call psb_spspmm(da,atmp,dadap,info) - call atmp%free() - - ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) - ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) - call dap%mv_to(csc_dap) - call dadap%mv_to(csc_dadap) - - call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) - call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - ! !$ write(0,*) trim(name),' OMP :',omp - ! !$ write(0,*) trim(name),' ODEN:',oden - - omp = omp/oden - - ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - call am3%mv_to(acsr3) - ! Compute omega_int - ommx = dzero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = dzero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - do i=1, nrow - omf(i) = ommx - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero - if(psb_minreal(omf(i)) < dzero) omf(i) = dzero - end do - - omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) - - if (filter_mat) then - ! - ! Build the filtered matrix Af from A - ! - call la%cscnv(acsrf,info,dupl=psb_dupl_add_) - - do i=1,nrow - tmp = dzero - jd = -1 - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) jd = j - if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then - tmp=tmp+acsrf%val(j) - acsrf%val(j)=dzero - endif - enddo - if (jd == -1) then - write(0,*) 'Wrong input: we need the diagonal!!!!', i - else - acsrf%val(jd)=acsrf%val(jd)-tmp - end if - enddo - ! Take out zeroed terms - call acsrf%clean_zeros(info) - - ! - ! Build the smoothed prolongator using the filtered matrix - ! - do i=1,acsrf%get_nrows() - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) then - acsrf%val(j) = done - omf(i)*acsrf%val(j) - else - acsrf%val(j) = - omf(i)*acsrf%val(j) - end if - end do - end do - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - - call af%mv_from(acsrf) - ! - ! op_prol = (I-w*D*Af)Ptilde - ! Doing it this way means to consider diag(Af_i) - ! - ! - call psb_spspmm(af,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 1' - else - ! - ! Build the smoothed prolongator using the original matrix - ! - do i=1,acsr3%get_nrows() - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) == i) then - acsr3%val(j) = done - omf(i)*acsr3%val(j) - else - acsr3%val(j) = - omf(i)*acsr3%val(j) - end if - end do - end do - - call am3%mv_from(acsr3) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - ! - ! - ! op_prol = (I-w*D*A)Ptilde - ! - ! - call psb_spspmm(am3,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - end if - - - ! - ! Ok, let's start over with the restrictor - ! - call ptilde%transc(rtilde) - call la%cscnv(atmp,info,type='csr') - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.true.,rowscale=.true.) - nrt = am4%get_nrows() - call am4%csclip(atmp2,info,lone,nrt,lone,ncol) - call atmp2%cscnv(info,type='CSR') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) - call am4%free() - call atmp2%free() - - ! This is to compute the transpose. It ONLY works if the - ! original A has a symmetric pattern. - call atmp%transc(atmp2) - call atmp2%csclip(dat,info,lone,nrow,lone,ncol) - call dat%cscnv(info,type='csr') - call dat%scal(adinv,info) - - ! Now for the product. - call psb_spspmm(dat,ptilde,datp,info) - - call datp%clone(atmp2,info) - call psb_sphalo(atmp2,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) - if (info == psb_success_) call am4%free() - - - call psb_symbmm(dat,atmp2,datdatp,info) - call psb_numbmm(dat,atmp2,datdatp) - call atmp2%free() - - call datp%mv_to(csc_datp) - call datdatp%mv_to(csc_datdatp) - - call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) - call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - - - ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp - ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden - omp = omp/oden - ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) - ! Compute omega_int - ommx = dzero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = dzero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - ! Going over the columns of atmp means going over the rows - ! of A^T. Hopefully ;-) - call atmp%cp_to(acsc) - - do i=1, nrow - omf(i) = ommx - do j= acsc%icp(i),acsc%icp(i+1)-1 - if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero - if(psb_minreal(omf(i)) < dzero) omf(i) = dzero - end do - omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) - call psb_halo(omf,desc_a,info) - call acsc%free() - - - call atmp%mv_to(acsr1) - - do i=1,acsr1%get_nrows() - do j=acsr1%irp(i),acsr1%irp(i+1)-1 - if (acsr1%ja(j) == i) then - acsr1%val(j) = done - acsr1%val(j)*omf(acsr1%ja(j)) - else - acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) - end if - end do - end do - call atmp%mv_from(acsr1) - - call rtilde%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call rtilde%mv_from(tmpcoo) - call rtilde%cscnv(info,type='csr') - - call psb_spspmm(rtilde,atmp,op_restr,info) - - ! - ! Now we have to gather the halo of op_prol, and add it to itself - ! to multiply it by A, - ! - call op_prol%clone(tmp_prol,info) - if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') - goto 9999 - end if - - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - call op_restr%mv_to(tmpcoo) - - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - - call psb_spspmm(la,tmp_prol,am3,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 2' - - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Extend am3') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done sphalo/ rwxtd' - - call psb_spspmm(op_restr,am3,ac,info) - if (info == psb_success_) call am3%free() - if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build ac = op_restr x am3') - goto 9999 - end if +!!$ ! Get the diagonal D +!!$ adiag = a%get_diag(info) +!!$ if (info == psb_success_) & +!!$ & call psb_realloc(ncol,adiag,info) +!!$ if (info == psb_success_) & +!!$ & call psb_halo(adiag,desc_a,info) +!!$ if (info == psb_success_) call a%cp_to_l(la) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') +!!$ goto 9999 +!!$ end if +!!$ +!!$ do i=1,size(adiag) +!!$ if (adiag(i) /= dzero) then +!!$ adinv(i) = done / adiag(i) +!!$ else +!!$ adinv(i) = done +!!$ end if +!!$ end do +!!$ +!!$ +!!$ +!!$ ! 1. Allocate Ptilde in sparse matrix form +!!$ call op_prol%mv_to(tmpcoo) +!!$ call ptilde%mv_from(tmpcoo) +!!$ call ptilde%cscnv(info,type='csr') +!!$ +!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & ' Initial copies done.' +!!$ +!!$ call da%scal(adinv,info) +!!$ +!!$ call psb_spspmm(da,ptilde,dap,info) +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call dap%clone(atmp,info) +!!$ +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ call psb_spspmm(da,atmp,dadap,info) +!!$ call atmp%free() +!!$ +!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) +!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) +!!$ call dap%mv_to(csc_dap) +!!$ call dadap%mv_to(csc_dadap) +!!$ +!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) +!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ ! !$ write(0,*) trim(name),' OMP :',omp +!!$ ! !$ write(0,*) trim(name),' ODEN:',oden +!!$ +!!$ omp = omp/oden +!!$ +!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ call am3%mv_to(acsr3) +!!$ ! Compute omega_int +!!$ ommx = dzero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = dzero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero +!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = dzero +!!$ end do +!!$ +!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) +!!$ +!!$ if (filter_mat) then +!!$ ! +!!$ ! Build the filtered matrix Af from A +!!$ ! +!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_) +!!$ +!!$ do i=1,nrow +!!$ tmp = dzero +!!$ jd = -1 +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) jd = j +!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then +!!$ tmp=tmp+acsrf%val(j) +!!$ acsrf%val(j)=dzero +!!$ endif +!!$ enddo +!!$ if (jd == -1) then +!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i +!!$ else +!!$ acsrf%val(jd)=acsrf%val(jd)-tmp +!!$ end if +!!$ enddo +!!$ ! Take out zeroed terms +!!$ call acsrf%clean_zeros(info) +!!$ +!!$ ! +!!$ ! Build the smoothed prolongator using the filtered matrix +!!$ ! +!!$ do i=1,acsrf%get_nrows() +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) then +!!$ acsrf%val(j) = done - omf(i)*acsrf%val(j) +!!$ else +!!$ acsrf%val(j) = - omf(i)*acsrf%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ +!!$ call af%mv_from(acsrf) +!!$ ! +!!$ ! op_prol = (I-w*D*Af)Ptilde +!!$ ! Doing it this way means to consider diag(Af_i) +!!$ ! +!!$ ! +!!$ call psb_spspmm(af,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 1' +!!$ else +!!$ ! +!!$ ! Build the smoothed prolongator using the original matrix +!!$ ! +!!$ do i=1,acsr3%get_nrows() +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if (acsr3%ja(j) == i) then +!!$ acsr3%val(j) = done - omf(i)*acsr3%val(j) +!!$ else +!!$ acsr3%val(j) = - omf(i)*acsr3%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ call am3%mv_from(acsr3) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ ! +!!$ ! +!!$ ! op_prol = (I-w*D*A)Ptilde +!!$ ! +!!$ ! +!!$ call psb_spspmm(am3,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ end if +!!$ +!!$ +!!$ ! +!!$ ! Ok, let's start over with the restrictor +!!$ ! +!!$ call ptilde%transc(rtilde) +!!$ call la%cscnv(atmp,info,type='csr') +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.true.,rowscale=.true.) +!!$ nrt = am4%get_nrows() +!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol) +!!$ call atmp2%cscnv(info,type='CSR') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) +!!$ call am4%free() +!!$ call atmp2%free() +!!$ +!!$ ! This is to compute the transpose. It ONLY works if the +!!$ ! original A has a symmetric pattern. +!!$ call atmp%transc(atmp2) +!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol) +!!$ call dat%cscnv(info,type='csr') +!!$ call dat%scal(adinv,info) +!!$ +!!$ ! Now for the product. +!!$ call psb_spspmm(dat,ptilde,datp,info) +!!$ +!!$ call datp%clone(atmp2,info) +!!$ call psb_sphalo(atmp2,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ +!!$ call psb_symbmm(dat,atmp2,datdatp,info) +!!$ call psb_numbmm(dat,atmp2,datdatp) +!!$ call atmp2%free() +!!$ +!!$ call datp%mv_to(csc_datp) +!!$ call datdatp%mv_to(csc_datdatp) +!!$ +!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) +!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ +!!$ +!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp +!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden +!!$ omp = omp/oden +!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) +!!$ ! Compute omega_int +!!$ ommx = dzero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = dzero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ ! Going over the columns of atmp means going over the rows +!!$ ! of A^T. Hopefully ;-) +!!$ call atmp%cp_to(acsc) +!!$ +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j= acsc%icp(i),acsc%icp(i+1)-1 +!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = dzero +!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = dzero +!!$ end do +!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) +!!$ call psb_halo(omf,desc_a,info) +!!$ call acsc%free() +!!$ +!!$ +!!$ call atmp%mv_to(acsr1) +!!$ +!!$ do i=1,acsr1%get_nrows() +!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1 +!!$ if (acsr1%ja(j) == i) then +!!$ acsr1%val(j) = done - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ else +!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ end if +!!$ end do +!!$ end do +!!$ call atmp%mv_from(acsr1) +!!$ +!!$ call rtilde%mv_to(tmpcoo) +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call rtilde%mv_from(tmpcoo) +!!$ call rtilde%cscnv(info,type='csr') +!!$ +!!$ call psb_spspmm(rtilde,atmp,op_restr,info) +!!$ +!!$ ! +!!$ ! Now we have to gather the halo of op_prol, and add it to itself +!!$ ! to multiply it by A, +!!$ ! +!!$ call op_prol%clone(tmp_prol,info) +!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') +!!$ goto 9999 +!!$ end if +!!$ +!!$ ! +!!$ ! Now we have to fix this. The only rows of B that are correct +!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) +!!$ ! +!!$ call op_restr%mv_to(tmpcoo) +!!$ +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call op_restr%mv_from(tmpcoo) +!!$ call op_restr%cscnv(info,type='csr') +!!$ +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'starting sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(la,tmp_prol,am3,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 2' +!!$ +!!$ call psb_sphalo(am3,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='Extend am3') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(op_restr,am3,ac,info) +!!$ if (info == psb_success_) call am3%free() +!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ &a_err='Build ac = op_restr x am3') +!!$ goto 9999 +!!$ end if diff --git a/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 b/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 index 20b24d60..82da3fc7 100644 --- a/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 +++ b/amgprec/impl/aggregator/amg_daggrmat_smth_bld.f90 @@ -116,7 +116,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms - type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr + type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_ldspmat_type), intent(inout) :: t_prol type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 index 0ab5274e..c52c04f7 100644 --- a/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 @@ -83,8 +83,8 @@ subroutine amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_s_dec_aggregator_type), target, intent(inout) :: ag type(amg_sml_parms), intent(inout) :: parms type(amg_saggr_data), intent(in) :: ag_data - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lsspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_s_parmatch_aggregator_tprol.F90 b/amgprec/impl/aggregator/amg_s_parmatch_aggregator_tprol.F90 index 2cb3d842..b68531d3 100644 --- a/amgprec/impl/aggregator/amg_s_parmatch_aggregator_tprol.F90 +++ b/amgprec/impl/aggregator/amg_s_parmatch_aggregator_tprol.F90 @@ -48,7 +48,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& use amg_base_prec_type use amg_s_inner_mod #if defined(SERIAL_MPI) - use amg_s_parmatch_aggregator_mod + use amg_s_parmatch_aggregator_mod #else use amg_s_parmatch_aggregator_mod, amg_protect_name => amg_s_parmatch_aggregator_build_tprol #endif @@ -58,7 +58,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& type(amg_sml_parms), intent(inout) :: parms type(amg_saggr_data), intent(in) :: ag_data type(psb_sspmat_type), intent(inout) :: a - type(psb_desc_type), intent(inout) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lsspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info @@ -68,7 +68,8 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& real(psb_spk_), allocatable :: tmpw(:), tmpwnxt(:) integer(psb_lpk_), allocatable :: ixaggr(:), nxaggr(:), tlaggr(:), ivr(:) type(psb_sspmat_type) :: a_tmp - integer(c_int) :: match_algorithm, n_sweeps, max_csize, max_nlevels + integer(psb_ipk_) :: match_algorithm, n_sweeps + integer(psb_lpk_) :: target_csize character(len=40) :: name, ch_err character(len=80) :: fname, prefix_ type(psb_ctxt_type) :: ictxt @@ -128,27 +129,22 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& write(debug_unit, *) 'Warning: AGGR_SIZE reset to value ',2**n_sweeps end if end if - if (ag%max_csize > 0) then - max_csize = ag%max_csize + if (ag_data%target_coarse_size > 0) then + target_csize = ag_data%target_coarse_size else - max_csize = ag_data%min_coarse_size - end if - if (ag%max_nlevels > 0) then - max_nlevels = ag%max_nlevels - else - max_nlevels = ag_data%max_levs + target_csize = ag_data%min_coarse_size end if if (.true.) then block integer(psb_ipk_) :: ipv(2) - ipv(1) = max_csize + ipv(1) = target_csize ipv(2) = n_sweeps call psb_bcast(ictxt,ipv) - max_csize = ipv(1) + target_csize = ipv(1) n_sweeps = ipv(2) end block else - call psb_bcast(ictxt,max_csize) + call psb_bcast(ictxt,target_csize) call psb_bcast(ictxt,n_sweeps) end if if (n_sweeps /= ag%n_sweeps) then @@ -156,7 +152,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& end if !!$ if (me==0) write(0,*) 'Matching sweeps: ',n_sweeps n_sweeps = max(1,n_sweeps) - if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,max_csize + if (debug) write(0,*) me,' Copies, with n_sweeps: ',n_sweeps,target_csize if (ag%unsmoothed_hierarchy.and.allocated(ag%base_a)) then call ag%base_a%cp_to(acsr) if (ag%do_clean_zeros) call acsr%clean_zeros(info) @@ -242,7 +238,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& if (debug) then call psb_barrier(ictxt) - if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),max_csize + if (me == 0) write(0,*) 'N_sweeps ',n_sweeps,nr,desc_acv(0)%is_ok(),target_csize end if ! @@ -264,7 +260,7 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& ! if (debug) write(0,*) me,' Into matchbox_build_prol ',info if (do_timings) call psb_tic(idx_mboxp) - call smatchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,& + call amg_s_matchboxp_build_prol(tmpw,acv(i-1),desc_acv(i-1),ixaggr,nxaggr,tmp_prol,info,& & symmetrize=ag%need_symmetrize,reproducible=ag%reproducible_matching) if (do_timings) call psb_toc(idx_mboxp) if (debug) write(0,*) me,' Out from matchbox_build_prol ',info @@ -300,11 +296,11 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& if (debug) then call psb_barrier(ictxt) - if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),max_csize,info + if (me==0) write(0,*) me,trim(name),' Done mat_asb:',i,sum(nxaggr),target_csize,info csz = sum(nxaggr) call psb_bcast(ictxt,csz) if (csz /= sum(nxaggr)) write(0,*) me,trim(name),' Mismatch matasb',& - & csz,sum(nxaggr),max_csize + & csz,sum(nxaggr),target_csize end if if (psb_errstatus_fatal()) write(0,*)me,trim(name),'Error fatal on entry to tmpwnxt 2' @@ -342,10 +338,10 @@ subroutine amg_s_parmatch_aggregator_build_tprol(ag,parms,ag_data,& call move_alloc(tmpwnxt,tmpw) if (debug) then if (csz /= sum(nlaggr)) write(0,*) me,trim(name),' Mismatch 2 matasb',& - & csz,sum(nlaggr),max_csize, info + & csz,sum(nlaggr),target_csize, info end if call acv(i-1)%free() - if ((sum(nlaggr) <= max_csize).or.(any(nlaggr==0))) then + if ((sum(nlaggr) <= target_csize).or.(any(nlaggr==0))) then x_sweeps = i exit sweeps_loop end if diff --git a/amgprec/impl/aggregator/amg_s_parmatch_smth_bld.F90 b/amgprec/impl/aggregator/amg_s_parmatch_smth_bld.F90 index a89ac411..a3f79fc5 100644 --- a/amgprec/impl/aggregator/amg_s_parmatch_smth_bld.F90 +++ b/amgprec/impl/aggregator/amg_s_parmatch_smth_bld.F90 @@ -122,7 +122,7 @@ subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,& integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol - type(psb_sspmat_type), intent(out) :: op_prol,ac,op_restr + type(psb_sspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld.F90 b/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld.F90 index b88930eb..3f9e385e 100644 --- a/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld.F90 +++ b/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld.F90 @@ -108,7 +108,7 @@ subroutine amg_s_parmatch_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,& ! Arguments type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol diff --git a/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_inner.F90 b/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_inner.F90 index cb64c0e1..9f1c81f1 100644 --- a/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_inner.F90 +++ b/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_inner.F90 @@ -108,11 +108,11 @@ subroutine amg_s_parmatch_spmm_bld_inner(a_csr,desc_a,ilaggr,nlaggr,parms,& ! Arguments type(psb_s_csr_sparse_mat), intent(inout) :: a_csr - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol - type(psb_sspmat_type), intent(out) :: ac, op_prol, op_restr + type(psb_sspmat_type), intent(inout) :: ac, op_prol, op_restr type(psb_desc_type), intent(out) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_ov.F90 b/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_ov.F90 index a4fa85e7..442f4225 100644 --- a/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_ov.F90 +++ b/amgprec/impl/aggregator/amg_s_parmatch_spmm_bld_ov.F90 @@ -108,7 +108,7 @@ subroutine amg_s_parmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,& ! Arguments type(psb_sspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms type(psb_lsspmat_type), intent(inout) :: t_prol diff --git a/amgprec/impl/aggregator/amg_s_symdec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_s_symdec_aggregator_tprol.f90 index 5a9548eb..c148b89a 100644 --- a/amgprec/impl/aggregator/amg_s_symdec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_s_symdec_aggregator_tprol.f90 @@ -86,8 +86,8 @@ subroutine amg_s_symdec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_s_symdec_aggregator_type), target, intent(inout) :: ag type(amg_sml_parms), intent(inout) :: parms type(amg_saggr_data), intent(in) :: ag_data - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lsspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_saggrmat_minnrg_bld.f90 b/amgprec/impl/aggregator/amg_saggrmat_minnrg_bld.f90 index 670617fe..66514a66 100644 --- a/amgprec/impl/aggregator/amg_saggrmat_minnrg_bld.f90 +++ b/amgprec/impl/aggregator/amg_saggrmat_minnrg_bld.f90 @@ -105,7 +105,7 @@ ! ! subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& - & ac,desc_ac,op_prol,op_restr,info) + & ac,desc_ac,op_prol,op_restr,t_prol,info) use psb_base_mod use amg_base_prec_type use amg_s_inner_mod, amg_protect_name => amg_saggrmat_minnrg_bld @@ -117,8 +117,8 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms - type(psb_lsspmat_type), intent(inout) :: op_prol - type(psb_lsspmat_type), intent(out) :: ac,op_restr + type(psb_lsspmat_type), intent(inout) :: t_prol + type(psb_sspmat_type), intent(inout) :: op_prol, ac,op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info @@ -171,6 +171,8 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& filter_mat = (parms%aggr_filter == amg_filter_mat_) + !NEEDS TO BE REWORKED !! + ! naggr: number of local aggregates ! nrow: local rows. ! @@ -183,361 +185,361 @@ subroutine amg_saggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& goto 9999 end if - ! Get the diagonal D - adiag = a%get_diag(info) - if (info == psb_success_) & - & call psb_realloc(ncol,adiag,info) - if (info == psb_success_) & - & call psb_halo(adiag,desc_a,info) - if (info == psb_success_) call a%cp_to_l(la) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') - goto 9999 - end if - - do i=1,size(adiag) - if (adiag(i) /= szero) then - adinv(i) = sone / adiag(i) - else - adinv(i) = sone - end if - end do - - - - ! 1. Allocate Ptilde in sparse matrix form - call op_prol%mv_to(tmpcoo) - call ptilde%mv_from(tmpcoo) - call ptilde%cscnv(info,type='csr') - - if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Initial copies done.' - - call da%scal(adinv,info) - - call psb_spspmm(da,ptilde,dap,info) - - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') - goto 9999 - end if - - call dap%clone(atmp,info) - - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) - if (info == psb_success_) call am4%free() - - call psb_spspmm(da,atmp,dadap,info) - call atmp%free() - - ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) - ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) - call dap%mv_to(csc_dap) - call dadap%mv_to(csc_dadap) - - call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) - call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - ! !$ write(0,*) trim(name),' OMP :',omp - ! !$ write(0,*) trim(name),' ODEN:',oden - - omp = omp/oden - - ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - call am3%mv_to(acsr3) - ! Compute omega_int - ommx = szero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = szero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - do i=1, nrow - omf(i) = ommx - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero - if(psb_minreal(omf(i)) < szero) omf(i) = szero - end do - - omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) - - if (filter_mat) then - ! - ! Build the filtered matrix Af from A - ! - call la%cscnv(acsrf,info,dupl=psb_dupl_add_) - - do i=1,nrow - tmp = szero - jd = -1 - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) jd = j - if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then - tmp=tmp+acsrf%val(j) - acsrf%val(j)=szero - endif - enddo - if (jd == -1) then - write(0,*) 'Wrong input: we need the diagonal!!!!', i - else - acsrf%val(jd)=acsrf%val(jd)-tmp - end if - enddo - ! Take out zeroed terms - call acsrf%clean_zeros(info) - - ! - ! Build the smoothed prolongator using the filtered matrix - ! - do i=1,acsrf%get_nrows() - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) then - acsrf%val(j) = sone - omf(i)*acsrf%val(j) - else - acsrf%val(j) = - omf(i)*acsrf%val(j) - end if - end do - end do - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - - call af%mv_from(acsrf) - ! - ! op_prol = (I-w*D*Af)Ptilde - ! Doing it this way means to consider diag(Af_i) - ! - ! - call psb_spspmm(af,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 1' - else - ! - ! Build the smoothed prolongator using the original matrix - ! - do i=1,acsr3%get_nrows() - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) == i) then - acsr3%val(j) = sone - omf(i)*acsr3%val(j) - else - acsr3%val(j) = - omf(i)*acsr3%val(j) - end if - end do - end do - - call am3%mv_from(acsr3) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - ! - ! - ! op_prol = (I-w*D*A)Ptilde - ! - ! - call psb_spspmm(am3,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - end if - - - ! - ! Ok, let's start over with the restrictor - ! - call ptilde%transc(rtilde) - call la%cscnv(atmp,info,type='csr') - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.true.,rowscale=.true.) - nrt = am4%get_nrows() - call am4%csclip(atmp2,info,lone,nrt,lone,ncol) - call atmp2%cscnv(info,type='CSR') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) - call am4%free() - call atmp2%free() - - ! This is to compute the transpose. It ONLY works if the - ! original A has a symmetric pattern. - call atmp%transc(atmp2) - call atmp2%csclip(dat,info,lone,nrow,lone,ncol) - call dat%cscnv(info,type='csr') - call dat%scal(adinv,info) - - ! Now for the product. - call psb_spspmm(dat,ptilde,datp,info) - - call datp%clone(atmp2,info) - call psb_sphalo(atmp2,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) - if (info == psb_success_) call am4%free() - - - call psb_symbmm(dat,atmp2,datdatp,info) - call psb_numbmm(dat,atmp2,datdatp) - call atmp2%free() - - call datp%mv_to(csc_datp) - call datdatp%mv_to(csc_datdatp) - - call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) - call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - - - ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp - ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden - omp = omp/oden - ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) - ! Compute omega_int - ommx = szero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = szero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - ! Going over the columns of atmp means going over the rows - ! of A^T. Hopefully ;-) - call atmp%cp_to(acsc) - - do i=1, nrow - omf(i) = ommx - do j= acsc%icp(i),acsc%icp(i+1)-1 - if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero - if(psb_minreal(omf(i)) < szero) omf(i) = szero - end do - omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) - call psb_halo(omf,desc_a,info) - call acsc%free() - - - call atmp%mv_to(acsr1) - - do i=1,acsr1%get_nrows() - do j=acsr1%irp(i),acsr1%irp(i+1)-1 - if (acsr1%ja(j) == i) then - acsr1%val(j) = sone - acsr1%val(j)*omf(acsr1%ja(j)) - else - acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) - end if - end do - end do - call atmp%mv_from(acsr1) - - call rtilde%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call rtilde%mv_from(tmpcoo) - call rtilde%cscnv(info,type='csr') - - call psb_spspmm(rtilde,atmp,op_restr,info) - - ! - ! Now we have to gather the halo of op_prol, and add it to itself - ! to multiply it by A, - ! - call op_prol%clone(tmp_prol,info) - if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') - goto 9999 - end if - - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - call op_restr%mv_to(tmpcoo) - - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - - call psb_spspmm(la,tmp_prol,am3,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 2' - - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Extend am3') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done sphalo/ rwxtd' - - call psb_spspmm(op_restr,am3,ac,info) - if (info == psb_success_) call am3%free() - if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build ac = op_restr x am3') - goto 9999 - end if +!!$ ! Get the diagonal D +!!$ adiag = a%get_diag(info) +!!$ if (info == psb_success_) & +!!$ & call psb_realloc(ncol,adiag,info) +!!$ if (info == psb_success_) & +!!$ & call psb_halo(adiag,desc_a,info) +!!$ if (info == psb_success_) call a%cp_to_l(la) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') +!!$ goto 9999 +!!$ end if +!!$ +!!$ do i=1,size(adiag) +!!$ if (adiag(i) /= szero) then +!!$ adinv(i) = sone / adiag(i) +!!$ else +!!$ adinv(i) = sone +!!$ end if +!!$ end do +!!$ +!!$ +!!$ +!!$ ! 1. Allocate Ptilde in sparse matrix form +!!$ call op_prol%mv_to(tmpcoo) +!!$ call ptilde%mv_from(tmpcoo) +!!$ call ptilde%cscnv(info,type='csr') +!!$ +!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & ' Initial copies done.' +!!$ +!!$ call da%scal(adinv,info) +!!$ +!!$ call psb_spspmm(da,ptilde,dap,info) +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call dap%clone(atmp,info) +!!$ +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ call psb_spspmm(da,atmp,dadap,info) +!!$ call atmp%free() +!!$ +!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) +!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) +!!$ call dap%mv_to(csc_dap) +!!$ call dadap%mv_to(csc_dadap) +!!$ +!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) +!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ ! !$ write(0,*) trim(name),' OMP :',omp +!!$ ! !$ write(0,*) trim(name),' ODEN:',oden +!!$ +!!$ omp = omp/oden +!!$ +!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ call am3%mv_to(acsr3) +!!$ ! Compute omega_int +!!$ ommx = szero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = szero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero +!!$ if(psb_minreal(omf(i)) < szero) omf(i) = szero +!!$ end do +!!$ +!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) +!!$ +!!$ if (filter_mat) then +!!$ ! +!!$ ! Build the filtered matrix Af from A +!!$ ! +!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_) +!!$ +!!$ do i=1,nrow +!!$ tmp = szero +!!$ jd = -1 +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) jd = j +!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then +!!$ tmp=tmp+acsrf%val(j) +!!$ acsrf%val(j)=szero +!!$ endif +!!$ enddo +!!$ if (jd == -1) then +!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i +!!$ else +!!$ acsrf%val(jd)=acsrf%val(jd)-tmp +!!$ end if +!!$ enddo +!!$ ! Take out zeroed terms +!!$ call acsrf%clean_zeros(info) +!!$ +!!$ ! +!!$ ! Build the smoothed prolongator using the filtered matrix +!!$ ! +!!$ do i=1,acsrf%get_nrows() +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) then +!!$ acsrf%val(j) = sone - omf(i)*acsrf%val(j) +!!$ else +!!$ acsrf%val(j) = - omf(i)*acsrf%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ +!!$ call af%mv_from(acsrf) +!!$ ! +!!$ ! op_prol = (I-w*D*Af)Ptilde +!!$ ! Doing it this way means to consider diag(Af_i) +!!$ ! +!!$ ! +!!$ call psb_spspmm(af,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 1' +!!$ else +!!$ ! +!!$ ! Build the smoothed prolongator using the original matrix +!!$ ! +!!$ do i=1,acsr3%get_nrows() +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if (acsr3%ja(j) == i) then +!!$ acsr3%val(j) = sone - omf(i)*acsr3%val(j) +!!$ else +!!$ acsr3%val(j) = - omf(i)*acsr3%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ call am3%mv_from(acsr3) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ ! +!!$ ! +!!$ ! op_prol = (I-w*D*A)Ptilde +!!$ ! +!!$ ! +!!$ call psb_spspmm(am3,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ end if +!!$ +!!$ +!!$ ! +!!$ ! Ok, let's start over with the restrictor +!!$ ! +!!$ call ptilde%transc(rtilde) +!!$ call la%cscnv(atmp,info,type='csr') +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.true.,rowscale=.true.) +!!$ nrt = am4%get_nrows() +!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol) +!!$ call atmp2%cscnv(info,type='CSR') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) +!!$ call am4%free() +!!$ call atmp2%free() +!!$ +!!$ ! This is to compute the transpose. It ONLY works if the +!!$ ! original A has a symmetric pattern. +!!$ call atmp%transc(atmp2) +!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol) +!!$ call dat%cscnv(info,type='csr') +!!$ call dat%scal(adinv,info) +!!$ +!!$ ! Now for the product. +!!$ call psb_spspmm(dat,ptilde,datp,info) +!!$ +!!$ call datp%clone(atmp2,info) +!!$ call psb_sphalo(atmp2,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ +!!$ call psb_symbmm(dat,atmp2,datdatp,info) +!!$ call psb_numbmm(dat,atmp2,datdatp) +!!$ call atmp2%free() +!!$ +!!$ call datp%mv_to(csc_datp) +!!$ call datdatp%mv_to(csc_datdatp) +!!$ +!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) +!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ +!!$ +!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp +!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden +!!$ omp = omp/oden +!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) +!!$ ! Compute omega_int +!!$ ommx = szero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = szero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ ! Going over the columns of atmp means going over the rows +!!$ ! of A^T. Hopefully ;-) +!!$ call atmp%cp_to(acsc) +!!$ +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j= acsc%icp(i),acsc%icp(i+1)-1 +!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < szero) omf(i) = szero +!!$ if(psb_minreal(omf(i)) < szero) omf(i) = szero +!!$ end do +!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) +!!$ call psb_halo(omf,desc_a,info) +!!$ call acsc%free() +!!$ +!!$ +!!$ call atmp%mv_to(acsr1) +!!$ +!!$ do i=1,acsr1%get_nrows() +!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1 +!!$ if (acsr1%ja(j) == i) then +!!$ acsr1%val(j) = sone - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ else +!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ end if +!!$ end do +!!$ end do +!!$ call atmp%mv_from(acsr1) +!!$ +!!$ call rtilde%mv_to(tmpcoo) +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call rtilde%mv_from(tmpcoo) +!!$ call rtilde%cscnv(info,type='csr') +!!$ +!!$ call psb_spspmm(rtilde,atmp,op_restr,info) +!!$ +!!$ ! +!!$ ! Now we have to gather the halo of op_prol, and add it to itself +!!$ ! to multiply it by A, +!!$ ! +!!$ call op_prol%clone(tmp_prol,info) +!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') +!!$ goto 9999 +!!$ end if +!!$ +!!$ ! +!!$ ! Now we have to fix this. The only rows of B that are correct +!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) +!!$ ! +!!$ call op_restr%mv_to(tmpcoo) +!!$ +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call op_restr%mv_from(tmpcoo) +!!$ call op_restr%cscnv(info,type='csr') +!!$ +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'starting sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(la,tmp_prol,am3,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 2' +!!$ +!!$ call psb_sphalo(am3,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='Extend am3') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(op_restr,am3,ac,info) +!!$ if (info == psb_success_) call am3%free() +!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ &a_err='Build ac = op_restr x am3') +!!$ goto 9999 +!!$ end if diff --git a/amgprec/impl/aggregator/amg_saggrmat_smth_bld.f90 b/amgprec/impl/aggregator/amg_saggrmat_smth_bld.f90 index 30532e9c..d96176b2 100644 --- a/amgprec/impl/aggregator/amg_saggrmat_smth_bld.f90 +++ b/amgprec/impl/aggregator/amg_saggrmat_smth_bld.f90 @@ -116,7 +116,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_sml_parms), intent(inout) :: parms - type(psb_sspmat_type), intent(out) :: op_prol,ac,op_restr + type(psb_sspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_lsspmat_type), intent(inout) :: t_prol type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 index 5a90fcd5..a64e3ebb 100644 --- a/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 @@ -83,8 +83,8 @@ subroutine amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_z_dec_aggregator_type), target, intent(inout) :: ag type(amg_dml_parms), intent(inout) :: parms type(amg_daggr_data), intent(in) :: ag_data - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_zspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lzspmat_type), intent(out) :: t_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_z_symdec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_z_symdec_aggregator_tprol.f90 index 84de6849..dd4ac4be 100644 --- a/amgprec/impl/aggregator/amg_z_symdec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_z_symdec_aggregator_tprol.f90 @@ -86,8 +86,8 @@ subroutine amg_z_symdec_aggregator_build_tprol(ag,parms,ag_data,& class(amg_z_symdec_aggregator_type), target, intent(inout) :: ag type(amg_dml_parms), intent(inout) :: parms type(amg_daggr_data), intent(in) :: ag_data - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a + type(psb_zspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:) type(psb_lzspmat_type), intent(out) :: op_prol integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/aggregator/amg_zaggrmat_minnrg_bld.f90 b/amgprec/impl/aggregator/amg_zaggrmat_minnrg_bld.f90 index c8a6e227..89d6d89d 100644 --- a/amgprec/impl/aggregator/amg_zaggrmat_minnrg_bld.f90 +++ b/amgprec/impl/aggregator/amg_zaggrmat_minnrg_bld.f90 @@ -105,7 +105,7 @@ ! ! subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& - & ac,desc_ac,op_prol,op_restr,info) + & ac,desc_ac,op_prol,op_restr,t_prol,info) use psb_base_mod use amg_base_prec_type use amg_z_inner_mod, amg_protect_name => amg_zaggrmat_minnrg_bld @@ -117,8 +117,8 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms - type(psb_lzspmat_type), intent(inout) :: op_prol - type(psb_lzspmat_type), intent(out) :: ac,op_restr + type(psb_lzspmat_type), intent(inout) :: t_prol + type(psb_zspmat_type), intent(inout) :: op_prol, ac,op_restr type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info @@ -171,6 +171,8 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& filter_mat = (parms%aggr_filter == amg_filter_mat_) + !NEEDS TO BE REWORKED !! + ! naggr: number of local aggregates ! nrow: local rows. ! @@ -183,361 +185,361 @@ subroutine amg_zaggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,& goto 9999 end if - ! Get the diagonal D - adiag = a%get_diag(info) - if (info == psb_success_) & - & call psb_realloc(ncol,adiag,info) - if (info == psb_success_) & - & call psb_halo(adiag,desc_a,info) - if (info == psb_success_) call a%cp_to_l(la) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') - goto 9999 - end if - - do i=1,size(adiag) - if (adiag(i) /= zzero) then - adinv(i) = zone / adiag(i) - else - adinv(i) = zone - end if - end do - - - - ! 1. Allocate Ptilde in sparse matrix form - call op_prol%mv_to(tmpcoo) - call ptilde%mv_from(tmpcoo) - call ptilde%cscnv(info,type='csr') - - if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Initial copies done.' - - call da%scal(adinv,info) - - call psb_spspmm(da,ptilde,dap,info) - - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') - goto 9999 - end if - - call dap%clone(atmp,info) - - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) - if (info == psb_success_) call am4%free() - - call psb_spspmm(da,atmp,dadap,info) - call atmp%free() - - ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) - ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) - call dap%mv_to(csc_dap) - call dadap%mv_to(csc_dadap) - - call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) - call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - ! !$ write(0,*) trim(name),' OMP :',omp - ! !$ write(0,*) trim(name),' ODEN:',oden - - omp = omp/oden - - ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - call am3%mv_to(acsr3) - ! Compute omega_int - ommx = zzero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = zzero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - do i=1, nrow - omf(i) = ommx - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero - if(psb_minreal(omf(i)) < dzero) omf(i) = zzero - end do - - omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) - - if (filter_mat) then - ! - ! Build the filtered matrix Af from A - ! - call la%cscnv(acsrf,info,dupl=psb_dupl_add_) - - do i=1,nrow - tmp = zzero - jd = -1 - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) jd = j - if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then - tmp=tmp+acsrf%val(j) - acsrf%val(j)=zzero - endif - enddo - if (jd == -1) then - write(0,*) 'Wrong input: we need the diagonal!!!!', i - else - acsrf%val(jd)=acsrf%val(jd)-tmp - end if - enddo - ! Take out zeroed terms - call acsrf%clean_zeros(info) - - ! - ! Build the smoothed prolongator using the filtered matrix - ! - do i=1,acsrf%get_nrows() - do j=acsrf%irp(i),acsrf%irp(i+1)-1 - if (acsrf%ja(j) == i) then - acsrf%val(j) = zone - omf(i)*acsrf%val(j) - else - acsrf%val(j) = - omf(i)*acsrf%val(j) - end if - end do - end do - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - - call af%mv_from(acsrf) - ! - ! op_prol = (I-w*D*Af)Ptilde - ! Doing it this way means to consider diag(Af_i) - ! - ! - call psb_spspmm(af,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 1' - else - ! - ! Build the smoothed prolongator using the original matrix - ! - do i=1,acsr3%get_nrows() - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) == i) then - acsr3%val(j) = zone - omf(i)*acsr3%val(j) - else - acsr3%val(j) = - omf(i)*acsr3%val(j) - end if - end do - end do - - call am3%mv_from(acsr3) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done gather, going for SYMBMM 1' - ! - ! - ! op_prol = (I-w*D*A)Ptilde - ! - ! - call psb_spspmm(am3,ptilde,op_prol,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 1' - - end if - - - ! - ! Ok, let's start over with the restrictor - ! - call ptilde%transc(rtilde) - call la%cscnv(atmp,info,type='csr') - call psb_sphalo(atmp,desc_a,am4,info,& - & colcnv=.true.,rowscale=.true.) - nrt = am4%get_nrows() - call am4%csclip(atmp2,info,lone,nrt,lone,ncol) - call atmp2%cscnv(info,type='CSR') - if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) - call am4%free() - call atmp2%free() - - ! This is to compute the transpose. It ONLY works if the - ! original A has a symmetric pattern. - call atmp%transc(atmp2) - call atmp2%csclip(dat,info,lone,nrow,lone,ncol) - call dat%cscnv(info,type='csr') - call dat%scal(adinv,info) - - ! Now for the product. - call psb_spspmm(dat,ptilde,datp,info) - - call datp%clone(atmp2,info) - call psb_sphalo(atmp2,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.,outfmt='CSR ') - if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) - if (info == psb_success_) call am4%free() - - - call psb_symbmm(dat,atmp2,datdatp,info) - call psb_numbmm(dat,atmp2,datdatp) - call atmp2%free() - - call datp%mv_to(csc_datp) - call datdatp%mv_to(csc_datdatp) - - call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) - call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) - call psb_sum(ctxt,omp) - call psb_sum(ctxt,oden) - - - ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp - ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden - omp = omp/oden - ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) - ! Compute omega_int - ommx = zzero - do i=1, ncol - if (ilaggr(i) >0) then - omi(i) = omp(ilaggr(i)) - else - omi(i) = zzero - end if - if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) - end do - ! Compute omega_fine - ! Going over the columns of atmp means going over the rows - ! of A^T. Hopefully ;-) - call atmp%cp_to(acsc) - - do i=1, nrow - omf(i) = ommx - do j= acsc%icp(i),acsc%icp(i+1)-1 - if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) - end do -!!$ if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero - if(psb_minreal(omf(i)) < dzero) omf(i) = zzero - end do - omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) - call psb_halo(omf,desc_a,info) - call acsc%free() - - - call atmp%mv_to(acsr1) - - do i=1,acsr1%get_nrows() - do j=acsr1%irp(i),acsr1%irp(i+1)-1 - if (acsr1%ja(j) == i) then - acsr1%val(j) = zone - acsr1%val(j)*omf(acsr1%ja(j)) - else - acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) - end if - end do - end do - call atmp%mv_from(acsr1) - - call rtilde%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call rtilde%mv_from(tmpcoo) - call rtilde%cscnv(info,type='csr') - - call psb_spspmm(rtilde,atmp,op_restr,info) - - ! - ! Now we have to gather the halo of op_prol, and add it to itself - ! to multiply it by A, - ! - call op_prol%clone(tmp_prol,info) - if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') - goto 9999 - end if - - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - call op_restr%mv_to(tmpcoo) - - nzl = tmpcoo%get_nzeros() - i=0 - do k=1, nzl - if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then - i = i+1 - tmpcoo%val(i) = tmpcoo%val(k) - tmpcoo%ia(i) = tmpcoo%ia(k) - tmpcoo%ja(i) = tmpcoo%ja(k) - end if - end do - call tmpcoo%set_nzeros(i) - call op_restr%mv_from(tmpcoo) - call op_restr%cscnv(info,type='csr') - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'starting sphalo/ rwxtd' - - call psb_spspmm(la,tmp_prol,am3,info) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done SPSPMM 2' - - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Extend am3') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done sphalo/ rwxtd' - - call psb_spspmm(op_restr,am3,ac,info) - if (info == psb_success_) call am3%free() - if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build ac = op_restr x am3') - goto 9999 - end if +!!$ ! Get the diagonal D +!!$ adiag = a%get_diag(info) +!!$ if (info == psb_success_) & +!!$ & call psb_realloc(ncol,adiag,info) +!!$ if (info == psb_success_) & +!!$ & call psb_halo(adiag,desc_a,info) +!!$ if (info == psb_success_) call a%cp_to_l(la) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') +!!$ goto 9999 +!!$ end if +!!$ +!!$ do i=1,size(adiag) +!!$ if (adiag(i) /= zzero) then +!!$ adinv(i) = zone / adiag(i) +!!$ else +!!$ adinv(i) = zone +!!$ end if +!!$ end do +!!$ +!!$ +!!$ +!!$ ! 1. Allocate Ptilde in sparse matrix form +!!$ call op_prol%mv_to(tmpcoo) +!!$ call ptilde%mv_from(tmpcoo) +!!$ call ptilde%cscnv(info,type='csr') +!!$ +!!$ if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_) +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & ' Initial copies done.' +!!$ +!!$ call da%scal(adinv,info) +!!$ +!!$ call psb_spspmm(da,ptilde,dap,info) +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1') +!!$ goto 9999 +!!$ end if +!!$ +!!$ call dap%clone(atmp,info) +!!$ +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ call psb_spspmm(da,atmp,dadap,info) +!!$ call atmp%free() +!!$ +!!$ ! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) +!!$ ! !$ write(0,*) 'Columns of ADAP',psb_sp_get_ncols(adap) +!!$ call dap%mv_to(csc_dap) +!!$ call dadap%mv_to(csc_dadap) +!!$ +!!$ call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) +!!$ call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ ! !$ write(0,*) trim(name),' OMP :',omp +!!$ ! !$ write(0,*) trim(name),' ODEN:',oden +!!$ +!!$ omp = omp/oden +!!$ +!!$ ! !$ write(0,*) 'Check on output prolongator ',omp(1:min(size(omp),10)) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ call am3%mv_to(acsr3) +!!$ ! Compute omega_int +!!$ ommx = zzero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = zzero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if(abs(omi(acsr3%ja(j))) .lt. abs(omf(i))) omf(i)=omi(acsr3%ja(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero +!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = zzero +!!$ end do +!!$ +!!$ omf(1:nrow) = omf(1:nrow) * adinv(1:nrow) +!!$ +!!$ if (filter_mat) then +!!$ ! +!!$ ! Build the filtered matrix Af from A +!!$ ! +!!$ call la%cscnv(acsrf,info,dupl=psb_dupl_add_) +!!$ +!!$ do i=1,nrow +!!$ tmp = zzero +!!$ jd = -1 +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) jd = j +!!$ if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then +!!$ tmp=tmp+acsrf%val(j) +!!$ acsrf%val(j)=zzero +!!$ endif +!!$ enddo +!!$ if (jd == -1) then +!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i +!!$ else +!!$ acsrf%val(jd)=acsrf%val(jd)-tmp +!!$ end if +!!$ enddo +!!$ ! Take out zeroed terms +!!$ call acsrf%clean_zeros(info) +!!$ +!!$ ! +!!$ ! Build the smoothed prolongator using the filtered matrix +!!$ ! +!!$ do i=1,acsrf%get_nrows() +!!$ do j=acsrf%irp(i),acsrf%irp(i+1)-1 +!!$ if (acsrf%ja(j) == i) then +!!$ acsrf%val(j) = zone - omf(i)*acsrf%val(j) +!!$ else +!!$ acsrf%val(j) = - omf(i)*acsrf%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ +!!$ call af%mv_from(acsrf) +!!$ ! +!!$ ! op_prol = (I-w*D*Af)Ptilde +!!$ ! Doing it this way means to consider diag(Af_i) +!!$ ! +!!$ ! +!!$ call psb_spspmm(af,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 1' +!!$ else +!!$ ! +!!$ ! Build the smoothed prolongator using the original matrix +!!$ ! +!!$ do i=1,acsr3%get_nrows() +!!$ do j=acsr3%irp(i),acsr3%irp(i+1)-1 +!!$ if (acsr3%ja(j) == i) then +!!$ acsr3%val(j) = zone - omf(i)*acsr3%val(j) +!!$ else +!!$ acsr3%val(j) = - omf(i)*acsr3%val(j) +!!$ end if +!!$ end do +!!$ end do +!!$ +!!$ call am3%mv_from(acsr3) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done gather, going for SYMBMM 1' +!!$ ! +!!$ ! +!!$ ! op_prol = (I-w*D*A)Ptilde +!!$ ! +!!$ ! +!!$ call psb_spspmm(am3,ptilde,op_prol,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done NUMBMM 1' +!!$ +!!$ end if +!!$ +!!$ +!!$ ! +!!$ ! Ok, let's start over with the restrictor +!!$ ! +!!$ call ptilde%transc(rtilde) +!!$ call la%cscnv(atmp,info,type='csr') +!!$ call psb_sphalo(atmp,desc_a,am4,info,& +!!$ & colcnv=.true.,rowscale=.true.) +!!$ nrt = am4%get_nrows() +!!$ call am4%csclip(atmp2,info,lone,nrt,lone,ncol) +!!$ call atmp2%cscnv(info,type='CSR') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) +!!$ call am4%free() +!!$ call atmp2%free() +!!$ +!!$ ! This is to compute the transpose. It ONLY works if the +!!$ ! original A has a symmetric pattern. +!!$ call atmp%transc(atmp2) +!!$ call atmp2%csclip(dat,info,lone,nrow,lone,ncol) +!!$ call dat%cscnv(info,type='csr') +!!$ call dat%scal(adinv,info) +!!$ +!!$ ! Now for the product. +!!$ call psb_spspmm(dat,ptilde,datp,info) +!!$ +!!$ call datp%clone(atmp2,info) +!!$ call psb_sphalo(atmp2,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.,outfmt='CSR ') +!!$ if (info == psb_success_) call psb_rwextd(ncol,atmp2,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ +!!$ call psb_symbmm(dat,atmp2,datdatp,info) +!!$ call psb_numbmm(dat,atmp2,datdatp) +!!$ call atmp2%free() +!!$ +!!$ call datp%mv_to(csc_datp) +!!$ call datdatp%mv_to(csc_datdatp) +!!$ +!!$ call csc_mat_col_prod(csc_datp,csc_datdatp,omp,info) +!!$ call csc_mat_col_prod(csc_datdatp,csc_datdatp,oden,info) +!!$ call psb_sum(ctxt,omp) +!!$ call psb_sum(ctxt,oden) +!!$ +!!$ +!!$ ! !$ write(debug_unit,*) trim(name),' OMP_R :',omp +!!$ ! ! $ write(debug_unit,*) trim(name),' ODEN_R:',oden +!!$ omp = omp/oden +!!$ ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) +!!$ ! Compute omega_int +!!$ ommx = zzero +!!$ do i=1, ncol +!!$ if (ilaggr(i) >0) then +!!$ omi(i) = omp(ilaggr(i)) +!!$ else +!!$ omi(i) = zzero +!!$ end if +!!$ if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) +!!$ end do +!!$ ! Compute omega_fine +!!$ ! Going over the columns of atmp means going over the rows +!!$ ! of A^T. Hopefully ;-) +!!$ call atmp%cp_to(acsc) +!!$ +!!$ do i=1, nrow +!!$ omf(i) = ommx +!!$ do j= acsc%icp(i),acsc%icp(i+1)-1 +!!$ if(abs(omi(acsc%ia(j))) .lt. abs(omf(i))) omf(i)=omi(acsc%ia(j)) +!!$ end do +!!$ ! ! if(min(real(omf(i)),aimag(omf(i))) < dzero) omf(i) = zzero +!!$ if(psb_minreal(omf(i)) < dzero) omf(i) = zzero +!!$ end do +!!$ omf(1:nrow) = omf(1:nrow)*adinv(1:nrow) +!!$ call psb_halo(omf,desc_a,info) +!!$ call acsc%free() +!!$ +!!$ +!!$ call atmp%mv_to(acsr1) +!!$ +!!$ do i=1,acsr1%get_nrows() +!!$ do j=acsr1%irp(i),acsr1%irp(i+1)-1 +!!$ if (acsr1%ja(j) == i) then +!!$ acsr1%val(j) = zone - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ else +!!$ acsr1%val(j) = - acsr1%val(j)*omf(acsr1%ja(j)) +!!$ end if +!!$ end do +!!$ end do +!!$ call atmp%mv_from(acsr1) +!!$ +!!$ call rtilde%mv_to(tmpcoo) +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call rtilde%mv_from(tmpcoo) +!!$ call rtilde%cscnv(info,type='csr') +!!$ +!!$ call psb_spspmm(rtilde,atmp,op_restr,info) +!!$ +!!$ ! +!!$ ! Now we have to gather the halo of op_prol, and add it to itself +!!$ ! to multiply it by A, +!!$ ! +!!$ call op_prol%clone(tmp_prol,info) +!!$ if (info == psb_success_) call psb_sphalo(tmp_prol,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,tmp_prol,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') +!!$ goto 9999 +!!$ end if +!!$ +!!$ ! +!!$ ! Now we have to fix this. The only rows of B that are correct +!!$ ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) +!!$ ! +!!$ call op_restr%mv_to(tmpcoo) +!!$ +!!$ nzl = tmpcoo%get_nzeros() +!!$ i=0 +!!$ do k=1, nzl +!!$ if ((naggrm1 < tmpcoo%ia(k)) .and. (tmpcoo%ia(k) <= naggrp1)) then +!!$ i = i+1 +!!$ tmpcoo%val(i) = tmpcoo%val(k) +!!$ tmpcoo%ia(i) = tmpcoo%ia(k) +!!$ tmpcoo%ja(i) = tmpcoo%ja(k) +!!$ end if +!!$ end do +!!$ call tmpcoo%set_nzeros(i) +!!$ call op_restr%mv_from(tmpcoo) +!!$ call op_restr%cscnv(info,type='csr') +!!$ +!!$ +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'starting sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(la,tmp_prol,am3,info) +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done SPSPMM 2' +!!$ +!!$ call psb_sphalo(am3,desc_a,am4,info,& +!!$ & colcnv=.false.,rowscale=.true.) +!!$ if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) +!!$ if (info == psb_success_) call am4%free() +!!$ +!!$ if(info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ & a_err='Extend am3') +!!$ goto 9999 +!!$ end if +!!$ if (debug_level >= psb_debug_outer_) & +!!$ & write(debug_unit,*) me,' ',trim(name),& +!!$ & 'Done sphalo/ rwxtd' +!!$ +!!$ call psb_spspmm(op_restr,am3,ac,info) +!!$ if (info == psb_success_) call am3%free() +!!$ if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) +!!$ +!!$ if (info /= psb_success_) then +!!$ call psb_errpush(psb_err_internal_error_,name,& +!!$ &a_err='Build ac = op_restr x am3') +!!$ goto 9999 +!!$ end if diff --git a/amgprec/impl/aggregator/amg_zaggrmat_smth_bld.f90 b/amgprec/impl/aggregator/amg_zaggrmat_smth_bld.f90 index dc289067..2f944699 100644 --- a/amgprec/impl/aggregator/amg_zaggrmat_smth_bld.f90 +++ b/amgprec/impl/aggregator/amg_zaggrmat_smth_bld.f90 @@ -116,7 +116,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,& type(psb_desc_type), intent(inout) :: desc_a integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:) type(amg_dml_parms), intent(inout) :: parms - type(psb_zspmat_type), intent(out) :: op_prol,ac,op_restr + type(psb_zspmat_type), intent(inout) :: op_prol,ac,op_restr type(psb_lzspmat_type), intent(inout) :: t_prol type(psb_desc_type), intent(inout) :: desc_ac integer(psb_ipk_), intent(out) :: info diff --git a/amgprec/impl/amg_ccprecset.F90 b/amgprec/impl/amg_ccprecset.F90 index 3fb97bf3..5a917d10 100644 --- a/amgprec/impl/amg_ccprecset.F90 +++ b/amgprec/impl/amg_ccprecset.F90 @@ -571,7 +571,6 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_c_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select @@ -729,7 +728,6 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_c_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select diff --git a/amgprec/impl/amg_cprecset.F90 b/amgprec/impl/amg_cprecset.F90 index 818d51a8..ff96f6cc 100644 --- a/amgprec/impl/amg_cprecset.F90 +++ b/amgprec/impl/amg_cprecset.F90 @@ -45,7 +45,7 @@ subroutine amg_cprecsetsm(p,val,info,ilev,ilmax,pos) implicit none ! Arguments - class(amg_cprec_type), intent(inout) :: p + class(amg_cprec_type), target, intent(inout):: p class(amg_c_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev,ilmax diff --git a/amgprec/impl/amg_dcprecset.F90 b/amgprec/impl/amg_dcprecset.F90 index 4fe1dc0b..ad02a364 100644 --- a/amgprec/impl/amg_dcprecset.F90 +++ b/amgprec/impl/amg_dcprecset.F90 @@ -599,7 +599,6 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_d_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select @@ -773,7 +772,6 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_d_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select diff --git a/amgprec/impl/amg_dprecset.F90 b/amgprec/impl/amg_dprecset.F90 index 607e038f..16928156 100644 --- a/amgprec/impl/amg_dprecset.F90 +++ b/amgprec/impl/amg_dprecset.F90 @@ -45,7 +45,7 @@ subroutine amg_dprecsetsm(p,val,info,ilev,ilmax,pos) implicit none ! Arguments - class(amg_dprec_type), intent(inout) :: p + class(amg_dprec_type), target, intent(inout):: p class(amg_d_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev,ilmax diff --git a/amgprec/impl/amg_dslud_interface.c b/amgprec/impl/amg_dslud_interface.c index b3f0138f..2831c6f1 100644 --- a/amgprec/impl/amg_dslud_interface.c +++ b/amgprec/impl/amg_dslud_interface.c @@ -94,7 +94,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HANDLE_SIZE 8 -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) typedef struct { SuperMatrix *A; dLUstruct_t *LUstruct; @@ -135,7 +135,7 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr, SuperMatrix *A; NRformat_loc *Astore; -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) dScalePermstruct_t *ScalePermstruct; dLUstruct_t *LUstruct; dSOLVEstruct_t SOLVEstruct; @@ -148,9 +148,9 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr, int i, panel_size, permc_spec, relax, info; trans_t trans; double drop_tol = 0.0, b[1], berr[1]; -#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5) +#if (SLUD_VERSION_>=50) superlu_dist_options_t options; -#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) superlu_options_t options; #else choke_on_me; @@ -174,7 +174,7 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr, SLU_NR_loc, SLU_D, SLU_GE); /* Initialize ScalePermstruct and LUstruct. */ -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) ScalePermstruct = (dScalePermstruct_t *) SUPERLU_MALLOC(sizeof(dScalePermstruct_t)); LUstruct = (dLUstruct_t *) SUPERLU_MALLOC(sizeof(dLUstruct_t)); dScalePermstructInit(n,n, ScalePermstruct); @@ -183,11 +183,11 @@ int amg_dsludist_fact(int n, int nl, int nnzl, int ffstr, LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t)); ScalePermstructInit(n,n, ScalePermstruct); #endif -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) dLUstructInit(n, LUstruct); -#elif defined(SLUD_VERSION_4) || defined(SLUD_VERSION_5) || defined(SLUD_VERSION_6) +#elif (SLUD_VERSION_>=40) LUstructInit(n, LUstruct); -#elif defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) LUstructInit(n,n, LUstruct); #else choke_on_me; @@ -245,7 +245,7 @@ int amg_dsludist_solve(int itrans, int n, int nrhs, */ #ifdef Have_SLUDist_ SuperMatrix *A; -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) dScalePermstruct_t *ScalePermstruct; dLUstruct_t *LUstruct; dSOLVEstruct_t SOLVEstruct; @@ -259,9 +259,9 @@ int amg_dsludist_solve(int itrans, int n, int nrhs, trans_t trans; double drop_tol = 0.0; double *berr; -#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6) ||defined(SLUD_VERSION_5) +#if (SLUD_VERSION_>=50) superlu_dist_options_t options; -#elif defined(SLUD_VERSION_4)|| defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) superlu_options_t options; #else choke_on_me; @@ -331,7 +331,7 @@ int amg_dsludist_free(void *f_factors) */ #ifdef Have_SLUDist_ SuperMatrix *A; -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) dScalePermstruct_t *ScalePermstruct; dLUstruct_t *LUstruct; dSOLVEstruct_t SOLVEstruct; @@ -345,9 +345,9 @@ int amg_dsludist_free(void *f_factors) trans_t trans; double drop_tol = 0.0; double *berr; -#if defined(SLUD_VERSION_63)||defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5) +#if (SLUD_VERSION_>=50) superlu_dist_options_t options; -#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) superlu_options_t options; #else choke_on_me; @@ -368,7 +368,7 @@ int amg_dsludist_free(void *f_factors) // we either have a leak or a segfault here. // To be investigated further. //Destroy_CompRowLoc_Matrix_dist(A); -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) dScalePermstructFree(ScalePermstruct); dLUstructFree(LUstruct); #else diff --git a/amgprec/impl/amg_scprecset.F90 b/amgprec/impl/amg_scprecset.F90 index e82df5ba..43aa85db 100644 --- a/amgprec/impl/amg_scprecset.F90 +++ b/amgprec/impl/amg_scprecset.F90 @@ -571,7 +571,6 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_s_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select @@ -729,7 +728,6 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_s_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select diff --git a/amgprec/impl/amg_sprecset.F90 b/amgprec/impl/amg_sprecset.F90 index 1e5daed4..2b2c1c98 100644 --- a/amgprec/impl/amg_sprecset.F90 +++ b/amgprec/impl/amg_sprecset.F90 @@ -45,7 +45,7 @@ subroutine amg_sprecsetsm(p,val,info,ilev,ilmax,pos) implicit none ! Arguments - class(amg_sprec_type), intent(inout) :: p + class(amg_sprec_type), target, intent(inout):: p class(amg_s_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev,ilmax diff --git a/amgprec/impl/amg_zcprecset.F90 b/amgprec/impl/amg_zcprecset.F90 index 4e27ac15..ab6fde91 100644 --- a/amgprec/impl/amg_zcprecset.F90 +++ b/amgprec/impl/amg_zcprecset.F90 @@ -599,7 +599,6 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_z_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select @@ -773,7 +772,6 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx) type(amg_z_krm_solver_type) :: krm_slv call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_krm_,info,pos=pos) call p%precv(nlev_)%set(krm_slv,info) - call p%precv(nlev_)%default() call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos) end block end select diff --git a/amgprec/impl/amg_zprecset.F90 b/amgprec/impl/amg_zprecset.F90 index f5ef7fd7..0337b3c3 100644 --- a/amgprec/impl/amg_zprecset.F90 +++ b/amgprec/impl/amg_zprecset.F90 @@ -45,7 +45,7 @@ subroutine amg_zprecsetsm(p,val,info,ilev,ilmax,pos) implicit none ! Arguments - class(amg_zprec_type), intent(inout) :: p + class(amg_zprec_type), target, intent(inout):: p class(amg_z_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev,ilmax diff --git a/amgprec/impl/amg_zslud_interface.c b/amgprec/impl/amg_zslud_interface.c index c3120aa6..6170772a 100644 --- a/amgprec/impl/amg_zslud_interface.c +++ b/amgprec/impl/amg_zslud_interface.c @@ -94,7 +94,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #define HANDLE_SIZE 8 -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) typedef struct { SuperMatrix *A; zLUstruct_t *LUstruct; @@ -142,7 +142,7 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr, SuperMatrix *A; NRformat_loc *Astore; -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) zScalePermstruct_t *ScalePermstruct; zLUstruct_t *LUstruct; zSOLVEstruct_t SOLVEstruct; @@ -155,9 +155,9 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr, int i, panel_size, permc_spec, relax, info; trans_t trans; double drop_tol = 0.0,berr[1]; -#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5) +#if (SLUD_VERSION_>=50) superlu_dist_options_t options; -#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) superlu_options_t options; #else choke_on_me; @@ -181,7 +181,7 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr, SLU_NR_loc, SLU_Z, SLU_GE); /* Initialize ScalePermstruct and LUstruct. */ -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) ScalePermstruct = (zScalePermstruct_t *) SUPERLU_MALLOC(sizeof(zScalePermstruct_t)); LUstruct = (zLUstruct_t *) SUPERLU_MALLOC(sizeof(zLUstruct_t)); zScalePermstructInit(n,n, ScalePermstruct); @@ -190,11 +190,11 @@ int amg_zsludist_fact(int n, int nl, int nnzl, int ffstr, LUstruct = (LUstruct_t *) SUPERLU_MALLOC(sizeof(LUstruct_t)); ScalePermstructInit(n,n, ScalePermstruct); #endif -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) zLUstructInit(n, LUstruct); -#elif defined(SLUD_VERSION_4) || defined(SLUD_VERSION_5) || defined(SLUD_VERSION_6) +#elif (SLUD_VERSION_>=40) LUstructInit(n, LUstruct); -#elif defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) LUstructInit(n,n, LUstruct); #else choke_on_me; @@ -257,7 +257,7 @@ int amg_zsludist_solve(int itrans, int n, int nrhs, */ #ifdef Have_SLUDist_ SuperMatrix *A; -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) zScalePermstruct_t *ScalePermstruct; zLUstruct_t *LUstruct; zSOLVEstruct_t SOLVEstruct; @@ -271,9 +271,9 @@ int amg_zsludist_solve(int itrans, int n, int nrhs, trans_t trans; double drop_tol = 0.0; double *berr; -#if defined(SLUD_VERSION_63) || defined(SLUD_VERSION_6) ||defined(SLUD_VERSION_5) +#if (SLUD_VERSION_>=50) superlu_dist_options_t options; -#elif defined(SLUD_VERSION_4)|| defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) superlu_options_t options; #else choke_on_me; @@ -343,7 +343,7 @@ int amg_zsludist_free(void *f_factors) */ #ifdef Have_SLUDist_ SuperMatrix *A; -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) zScalePermstruct_t *ScalePermstruct; zLUstruct_t *LUstruct; zSOLVEstruct_t SOLVEstruct; @@ -357,9 +357,9 @@ int amg_zsludist_free(void *f_factors) trans_t trans; double drop_tol = 0.0; double *berr; -#if defined(SLUD_VERSION_63)||defined(SLUD_VERSION_6)||defined(SLUD_VERSION_5) +#if (SLUD_VERSION_>=50) superlu_dist_options_t options; -#elif defined(SLUD_VERSION_4)||defined(SLUD_VERSION_3) +#elif (SLUD_VERSION_>=30) superlu_options_t options; #else choke_on_me; @@ -380,7 +380,7 @@ int amg_zsludist_free(void *f_factors) // we either have a leak or a segfault here. // To be investigated further. //Destroy_CompRowLoc_Matrix_dist(A); -#if defined(SLUD_VERSION_63) +#if (SLUD_VERSION_>=63) zScalePermstructFree(ScalePermstruct); zLUstructFree(LUstruct); #else diff --git a/amgprec/impl/level/amg_c_base_onelev_descr.f90 b/amgprec/impl/level/amg_c_base_onelev_descr.f90 index 6fe7aef3..41a0f0c0 100644 --- a/amgprec/impl/level/amg_c_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_descr.f90 @@ -83,6 +83,8 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity) write(iout_,*) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) + end if + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then if (allocated(lv%aggr)) then call lv%aggr%descr(lv%parms,iout_,info) else diff --git a/amgprec/impl/level/amg_c_base_onelev_dump.f90 b/amgprec/impl/level/amg_c_base_onelev_dump.f90 index aba4bfa6..14b4c9b6 100644 --- a/amgprec/impl/level/amg_c_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_dump.f90 @@ -101,7 +101,13 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if if (global_num_) then - if (level >= 2) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then if (ac_) then ivr = lv%desc_ac%get_global_indices(owned=.false.) write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' @@ -126,7 +132,12 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if else - if (level >= 2) then + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then if (ac_) then write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' call lv%ac%print(fname,head=head) @@ -146,16 +157,7 @@ subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if - if (level >= 2) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) - end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) - end if - else + if (level >= 1) then if (allocated(lv%sm)) then call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) diff --git a/amgprec/impl/level/amg_d_base_onelev_descr.f90 b/amgprec/impl/level/amg_d_base_onelev_descr.f90 index 880d5f3d..60e49464 100644 --- a/amgprec/impl/level/amg_d_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_descr.f90 @@ -83,6 +83,8 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity) write(iout_,*) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) + end if + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then if (allocated(lv%aggr)) then call lv%aggr%descr(lv%parms,iout_,info) else diff --git a/amgprec/impl/level/amg_d_base_onelev_dump.f90 b/amgprec/impl/level/amg_d_base_onelev_dump.f90 index 32fe1e55..c1013d41 100644 --- a/amgprec/impl/level/amg_d_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_dump.f90 @@ -101,7 +101,13 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if if (global_num_) then - if (level >= 2) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then if (ac_) then ivr = lv%desc_ac%get_global_indices(owned=.false.) write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' @@ -126,7 +132,12 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if else - if (level >= 2) then + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then if (ac_) then write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' call lv%ac%print(fname,head=head) @@ -146,16 +157,7 @@ subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if - if (level >= 2) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) - end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) - end if - else + if (level >= 1) then if (allocated(lv%sm)) then call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) diff --git a/amgprec/impl/level/amg_s_base_onelev_descr.f90 b/amgprec/impl/level/amg_s_base_onelev_descr.f90 index 94b776eb..b96c005b 100644 --- a/amgprec/impl/level/amg_s_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_descr.f90 @@ -83,6 +83,8 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity) write(iout_,*) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) + end if + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then if (allocated(lv%aggr)) then call lv%aggr%descr(lv%parms,iout_,info) else diff --git a/amgprec/impl/level/amg_s_base_onelev_dump.f90 b/amgprec/impl/level/amg_s_base_onelev_dump.f90 index ba70a1a1..d30c0bf7 100644 --- a/amgprec/impl/level/amg_s_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_dump.f90 @@ -101,7 +101,13 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if if (global_num_) then - if (level >= 2) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then if (ac_) then ivr = lv%desc_ac%get_global_indices(owned=.false.) write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' @@ -126,7 +132,12 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if else - if (level >= 2) then + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then if (ac_) then write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' call lv%ac%print(fname,head=head) @@ -146,16 +157,7 @@ subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if - if (level >= 2) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) - end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) - end if - else + if (level >= 1) then if (allocated(lv%sm)) then call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) diff --git a/amgprec/impl/level/amg_z_base_onelev_descr.f90 b/amgprec/impl/level/amg_z_base_onelev_descr.f90 index a92cb79e..913289f7 100644 --- a/amgprec/impl/level/amg_z_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_descr.f90 @@ -83,6 +83,8 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity) write(iout_,*) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) + end if + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then if (allocated(lv%aggr)) then call lv%aggr%descr(lv%parms,iout_,info) else diff --git a/amgprec/impl/level/amg_z_base_onelev_dump.f90 b/amgprec/impl/level/amg_z_base_onelev_dump.f90 index 0c111355..5d0b8f27 100644 --- a/amgprec/impl/level/amg_z_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_dump.f90 @@ -101,7 +101,13 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if if (global_num_) then - if (level >= 2) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then if (ac_) then ivr = lv%desc_ac%get_global_indices(owned=.false.) write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' @@ -126,7 +132,12 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if else - if (level >= 2) then + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then if (ac_) then write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' call lv%ac%print(fname,head=head) @@ -146,16 +157,7 @@ subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& end if end if - if (level >= 2) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) - end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%desc_ac,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) - end if - else + if (level >= 1) then if (allocated(lv%sm)) then call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) diff --git a/amgprec/impl/smoother/amg_c_as_smoother_free.f90 b/amgprec/impl/smoother/amg_c_as_smoother_free.f90 index 77ae7e95..6c22e1d2 100644 --- a/amgprec/impl/smoother/amg_c_as_smoother_free.f90 +++ b/amgprec/impl/smoother/amg_c_as_smoother_free.f90 @@ -61,6 +61,7 @@ subroutine amg_c_as_smoother_free(sm,info) end if end if call sm%nd%free() + call sm%desc_data%free(info) call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_d_as_smoother_free.f90 b/amgprec/impl/smoother/amg_d_as_smoother_free.f90 index d6217e0f..b5e1aa6e 100644 --- a/amgprec/impl/smoother/amg_d_as_smoother_free.f90 +++ b/amgprec/impl/smoother/amg_d_as_smoother_free.f90 @@ -61,6 +61,7 @@ subroutine amg_d_as_smoother_free(sm,info) end if end if call sm%nd%free() + call sm%desc_data%free(info) call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_s_as_smoother_free.f90 b/amgprec/impl/smoother/amg_s_as_smoother_free.f90 index e245e17f..3085f485 100644 --- a/amgprec/impl/smoother/amg_s_as_smoother_free.f90 +++ b/amgprec/impl/smoother/amg_s_as_smoother_free.f90 @@ -61,6 +61,7 @@ subroutine amg_s_as_smoother_free(sm,info) end if end if call sm%nd%free() + call sm%desc_data%free(info) call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/smoother/amg_z_as_smoother_free.f90 b/amgprec/impl/smoother/amg_z_as_smoother_free.f90 index 3fce8b8a..dc6c98b6 100644 --- a/amgprec/impl/smoother/amg_z_as_smoother_free.f90 +++ b/amgprec/impl/smoother/amg_z_as_smoother_free.f90 @@ -61,6 +61,7 @@ subroutine amg_z_as_smoother_free(sm,info) end if end if call sm%nd%free() + call sm%desc_data%free(info) call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/solver/amg_c_base_solver_csetr.f90 b/amgprec/impl/solver/amg_c_base_solver_csetr.f90 index f5751876..b78209a4 100644 --- a/amgprec/impl/solver/amg_c_base_solver_csetr.f90 +++ b/amgprec/impl/solver/amg_c_base_solver_csetr.f90 @@ -42,7 +42,7 @@ subroutine amg_c_base_solver_csetr(sv,what,val,info,idx) Implicit None ! Arguments class(amg_c_base_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what + character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idx diff --git a/amgprec/impl/solver/amg_c_bwgs_solver_bld.f90 b/amgprec/impl/solver/amg_c_bwgs_solver_bld.f90 index 68b87e3a..f760c80f 100644 --- a/amgprec/impl/solver/amg_c_bwgs_solver_bld.f90 +++ b/amgprec/impl/solver/amg_c_bwgs_solver_bld.f90 @@ -44,7 +44,7 @@ subroutine amg_c_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Arguments type(psb_cspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(amg_c_bwgs_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_cspmat_type), intent(in), target, optional :: b diff --git a/amgprec/impl/solver/amg_c_krm_solver_impl.f90 b/amgprec/impl/solver/amg_c_krm_solver_impl.f90 index 12e6f039..3c93488f 100644 --- a/amgprec/impl/solver/amg_c_krm_solver_impl.f90 +++ b/amgprec/impl/solver/amg_c_krm_solver_impl.f90 @@ -77,7 +77,7 @@ ! This is the implementation file corresponding to amg_c_krm_solver_mod. ! ! -subroutine amg_c_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) +subroutine amg_c_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) use psb_base_mod use amg_c_krm_solver, amg_protect_name => amg_c_krm_solver_bld @@ -85,13 +85,14 @@ subroutine amg_c_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) Implicit None ! Arguments - type(psb_cspmat_type), intent(inout), target :: a + type(psb_cspmat_type), intent(in), target :: a Type(psb_desc_type), Intent(inout) :: desc_a class(amg_c_krm_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_cspmat_type), intent(in), target, optional :: b class(psb_c_base_sparse_mat), intent(in), optional :: amold class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota integer(psb_lpk_) :: lnr diff --git a/amgprec/impl/solver/amg_d_base_solver_csetr.f90 b/amgprec/impl/solver/amg_d_base_solver_csetr.f90 index 5c4affd9..8cae84ee 100644 --- a/amgprec/impl/solver/amg_d_base_solver_csetr.f90 +++ b/amgprec/impl/solver/amg_d_base_solver_csetr.f90 @@ -42,7 +42,7 @@ subroutine amg_d_base_solver_csetr(sv,what,val,info,idx) Implicit None ! Arguments class(amg_d_base_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what + character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idx diff --git a/amgprec/impl/solver/amg_d_bwgs_solver_bld.f90 b/amgprec/impl/solver/amg_d_bwgs_solver_bld.f90 index 88b56731..859c8ebe 100644 --- a/amgprec/impl/solver/amg_d_bwgs_solver_bld.f90 +++ b/amgprec/impl/solver/amg_d_bwgs_solver_bld.f90 @@ -44,7 +44,7 @@ subroutine amg_d_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Arguments type(psb_dspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(amg_d_bwgs_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_dspmat_type), intent(in), target, optional :: b diff --git a/amgprec/impl/solver/amg_d_krm_solver_impl.f90 b/amgprec/impl/solver/amg_d_krm_solver_impl.f90 index 63331533..dd308157 100644 --- a/amgprec/impl/solver/amg_d_krm_solver_impl.f90 +++ b/amgprec/impl/solver/amg_d_krm_solver_impl.f90 @@ -77,7 +77,7 @@ ! This is the implementation file corresponding to amg_d_krm_solver_mod. ! ! -subroutine amg_d_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) +subroutine amg_d_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) use psb_base_mod use amg_d_krm_solver, amg_protect_name => amg_d_krm_solver_bld @@ -85,13 +85,14 @@ subroutine amg_d_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) Implicit None ! Arguments - type(psb_dspmat_type), intent(inout), target :: a + type(psb_dspmat_type), intent(in), target :: a Type(psb_desc_type), Intent(inout) :: desc_a class(amg_d_krm_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_dspmat_type), intent(in), target, optional :: b class(psb_d_base_sparse_mat), intent(in), optional :: amold class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota integer(psb_lpk_) :: lnr diff --git a/amgprec/impl/solver/amg_s_base_solver_csetr.f90 b/amgprec/impl/solver/amg_s_base_solver_csetr.f90 index a7dcf1a4..74f59e0e 100644 --- a/amgprec/impl/solver/amg_s_base_solver_csetr.f90 +++ b/amgprec/impl/solver/amg_s_base_solver_csetr.f90 @@ -42,7 +42,7 @@ subroutine amg_s_base_solver_csetr(sv,what,val,info,idx) Implicit None ! Arguments class(amg_s_base_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what + character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idx diff --git a/amgprec/impl/solver/amg_s_bwgs_solver_bld.f90 b/amgprec/impl/solver/amg_s_bwgs_solver_bld.f90 index 3df9df7b..e96e1229 100644 --- a/amgprec/impl/solver/amg_s_bwgs_solver_bld.f90 +++ b/amgprec/impl/solver/amg_s_bwgs_solver_bld.f90 @@ -44,7 +44,7 @@ subroutine amg_s_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Arguments type(psb_sspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(amg_s_bwgs_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_sspmat_type), intent(in), target, optional :: b diff --git a/amgprec/impl/solver/amg_s_krm_solver_impl.f90 b/amgprec/impl/solver/amg_s_krm_solver_impl.f90 index c51aaccb..1b0efd1b 100644 --- a/amgprec/impl/solver/amg_s_krm_solver_impl.f90 +++ b/amgprec/impl/solver/amg_s_krm_solver_impl.f90 @@ -77,7 +77,7 @@ ! This is the implementation file corresponding to amg_s_krm_solver_mod. ! ! -subroutine amg_s_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) +subroutine amg_s_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) use psb_base_mod use amg_s_krm_solver, amg_protect_name => amg_s_krm_solver_bld @@ -85,13 +85,14 @@ subroutine amg_s_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) Implicit None ! Arguments - type(psb_sspmat_type), intent(inout), target :: a + type(psb_sspmat_type), intent(in), target :: a Type(psb_desc_type), Intent(inout) :: desc_a class(amg_s_krm_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_sspmat_type), intent(in), target, optional :: b class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota integer(psb_lpk_) :: lnr diff --git a/amgprec/impl/solver/amg_z_base_solver_csetr.f90 b/amgprec/impl/solver/amg_z_base_solver_csetr.f90 index 80875820..5c14d396 100644 --- a/amgprec/impl/solver/amg_z_base_solver_csetr.f90 +++ b/amgprec/impl/solver/amg_z_base_solver_csetr.f90 @@ -42,7 +42,7 @@ subroutine amg_z_base_solver_csetr(sv,what,val,info,idx) Implicit None ! Arguments class(amg_z_base_solver_type), intent(inout) :: sv - integer(psb_ipk_), intent(in) :: what + character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idx diff --git a/amgprec/impl/solver/amg_z_bwgs_solver_bld.f90 b/amgprec/impl/solver/amg_z_bwgs_solver_bld.f90 index 3db433fe..dec629f5 100644 --- a/amgprec/impl/solver/amg_z_bwgs_solver_bld.f90 +++ b/amgprec/impl/solver/amg_z_bwgs_solver_bld.f90 @@ -44,7 +44,7 @@ subroutine amg_z_bwgs_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) ! Arguments type(psb_zspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a + Type(psb_desc_type), Intent(inout) :: desc_a class(amg_z_bwgs_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_zspmat_type), intent(in), target, optional :: b diff --git a/amgprec/impl/solver/amg_z_krm_solver_impl.f90 b/amgprec/impl/solver/amg_z_krm_solver_impl.f90 index e4c4e308..33972c4b 100644 --- a/amgprec/impl/solver/amg_z_krm_solver_impl.f90 +++ b/amgprec/impl/solver/amg_z_krm_solver_impl.f90 @@ -77,7 +77,7 @@ ! This is the implementation file corresponding to amg_z_krm_solver_mod. ! ! -subroutine amg_z_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) +subroutine amg_z_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold) use psb_base_mod use amg_z_krm_solver, amg_protect_name => amg_z_krm_solver_bld @@ -85,13 +85,14 @@ subroutine amg_z_krm_solver_bld(a,desc_a,sv,info,b,amold,vmold) Implicit None ! Arguments - type(psb_zspmat_type), intent(inout), target :: a + type(psb_zspmat_type), intent(in), target :: a Type(psb_desc_type), Intent(inout) :: desc_a class(amg_z_krm_solver_type), intent(inout) :: sv integer(psb_ipk_), intent(out) :: info type(psb_zspmat_type), intent(in), target, optional :: b class(psb_z_base_sparse_mat), intent(in), optional :: amold class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold ! Local variables integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota integer(psb_lpk_) :: lnr diff --git a/config/pac.m4 b/config/pac.m4 index c26ec2a4..745bbfa6 100644 --- a/config/pac.m4 +++ b/config/pac.m4 @@ -852,6 +852,7 @@ if test "x$pac_sludist_header_ok" == "xyes" ; then dnl Maybe lib? SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib"; LIBS="$SLUDIST_LIBS -lm $save_LIBS"; + AC_MSG_CHECKING([for superlu_malloc_dist in $SLUDIST_LIBS]) AC_TRY_LINK_FUNC(superlu_malloc_dist, [amg4psblas_cv_have_superludist=yes;pac_sludist_lib_ok=yes;], [amg4psblas_cv_have_superludist=no;pac_sludist_lib_ok=no; @@ -861,12 +862,13 @@ if test "x$pac_sludist_header_ok" == "xyes" ; then dnl Maybe lib64? SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib64"; LIBS="$SLUDIST_LIBS -lm $save_LIBS"; + AC_MSG_CHECKING([for superlu_malloc_dist in $SLUDIST_LIBS]) AC_TRY_LINK_FUNC(superlu_malloc_dist, [amg4psblas_cv_have_superludist=yes;pac_sludist_lib_ok=yes;], [amg4psblas_cv_have_superludist=no;pac_sludist_lib_ok=no; SLUDIST_LIBS="";SLUDIST_INCLUDES=""]) fi - AC_MSG_RESULT($pac_sludist_lib_ok) + AC_MSG_RESULT([$pac_sludist_lib_ok $SLUDIST_LIBS]) fi if test "x$pac_sludist_lib_ok" == "xyes" ; then diff --git a/configure b/configure index cedf2c1e..4d7ac45a 100755 --- a/configure +++ b/configure @@ -658,9 +658,16 @@ LAPACK_LIBS EGREP GREP CPP +MPICXX MPIFC MPILIBS MPICC +am__fastdepCXX_FALSE +am__fastdepCXX_TRUE +CXXDEPMODE +ac_ct_CXX +CXXFLAGS +CXX am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE @@ -726,6 +733,7 @@ infodir docdir oldincludedir includedir +runstatedir localstatedir sharedstatedir sysconfdir @@ -757,10 +765,12 @@ enable_silent_rules enable_dependency_tracking enable_serial with_ccopt +with_cxxopt with_fcopt with_libs with_clibs with_flibs +with_cxxlibs with_library_path with_include_path with_module_path @@ -796,8 +806,12 @@ LIBS CC CFLAGS CPPFLAGS +CXX +CXXFLAGS +CCC MPICC MPIFC +MPICXX CPP' @@ -837,6 +851,7 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' @@ -1089,6 +1104,15 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1226,7 +1250,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir + libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1379,6 +1403,7 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] @@ -1435,6 +1460,8 @@ Optional Packages: Specify the directory for PSBLAS library. --with-ccopt additional [CCOPT] flags to be added: will prepend to [CCOPT] + --with-cxxopt additional [CXXOPT] flags to be added: will prepend + to [CXXOPT] --with-fcopt additional [FCOPT] flags to be added: will prepend to [FCOPT] --with-libs List additional link flags here. For example, @@ -1444,6 +1471,8 @@ Optional Packages: to [CLIBS] --with-flibs additional [FLIBS] flags to be added: will prepend to [FLIBS] + --with-cxxlibs additional [CXXLIBS] flags to be added: will prepend + to [CXXLIBS] --with-library-path additional [LIBRARYPATH] flags to be added: will prepend to [LIBRARYPATH] --with-include-path additional [INCLUDEPATH] flags to be added: will @@ -1504,8 +1533,11 @@ Some influential environment variables: CFLAGS C compiler flags CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory + CXX C++ compiler command + CXXFLAGS C++ compiler flags MPICC MPI C compiler command MPIFC MPI Fortran compiler command + MPICXX MPI C++ compiler command CPP C preprocessor Use these variables to override the choices made by `configure' or to help @@ -1664,6 +1696,44 @@ fi } # ac_fn_c_try_compile +# ac_fn_cxx_try_compile LINENO +# ---------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_cxx_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_cxx_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_cxx_try_compile + # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. @@ -1823,6 +1893,119 @@ fi } # ac_fn_fc_try_link +# ac_fn_cxx_try_link LINENO +# ------------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_cxx_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_cxx_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_cxx_try_link + +# ac_fn_cxx_check_func LINENO FUNC VAR +# ------------------------------------ +# Tests whether FUNC exists, setting the cache variable VAR accordingly +ac_fn_cxx_check_func () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +/* Define $2 to an innocuous variant, in case declares $2. + For example, HP-UX 11i declares gettimeofday. */ +#define $2 innocuous_$2 + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $2 (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $2 + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $2 (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$2 || defined __stub___$2 +choke me +#endif + +int +main () +{ +return $2 (); + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_link "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_cxx_check_func + # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes @@ -4354,6 +4537,393 @@ fi CFLAGS="$save_CFLAGS"; +save_CXXFLAGS="$CXXFLAGS"; +ac_ext=cpp +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_cxx_compiler_gnu +if test -z "$CXX"; then + if test -n "$CCC"; then + CXX=$CCC + else + if test -n "$ac_tool_prefix"; then + for ac_prog in CC xlc++ icpc g++ + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CXX+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CXX"; then + ac_cv_prog_CXX="$CXX" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CXX="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CXX=$ac_cv_prog_CXX +if test -n "$CXX"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5 +$as_echo "$CXX" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$CXX" && break + done +fi +if test -z "$CXX"; then + ac_ct_CXX=$CXX + for ac_prog in CC xlc++ icpc g++ +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CXX+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CXX"; then + ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CXX="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CXX=$ac_cv_prog_ac_ct_CXX +if test -n "$ac_ct_CXX"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5 +$as_echo "$ac_ct_CXX" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_CXX" && break +done + + if test "x$ac_ct_CXX" = x; then + CXX="g++" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CXX=$ac_ct_CXX + fi +fi + + fi +fi +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C++ compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C++ compiler" >&5 +$as_echo_n "checking whether we are using the GNU C++ compiler... " >&6; } +if ${ac_cv_cxx_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_cxx_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5 +$as_echo "$ac_cv_cxx_compiler_gnu" >&6; } +if test $ac_compiler_gnu = yes; then + GXX=yes +else + GXX= +fi +ac_test_CXXFLAGS=${CXXFLAGS+set} +ac_save_CXXFLAGS=$CXXFLAGS +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5 +$as_echo_n "checking whether $CXX accepts -g... " >&6; } +if ${ac_cv_prog_cxx_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_save_cxx_werror_flag=$ac_cxx_werror_flag + ac_cxx_werror_flag=yes + ac_cv_prog_cxx_g=no + CXXFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_compile "$LINENO"; then : + ac_cv_prog_cxx_g=yes +else + CXXFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_compile "$LINENO"; then : + +else + ac_cxx_werror_flag=$ac_save_cxx_werror_flag + CXXFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_compile "$LINENO"; then : + ac_cv_prog_cxx_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_cxx_werror_flag=$ac_save_cxx_werror_flag +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5 +$as_echo "$ac_cv_prog_cxx_g" >&6; } +if test "$ac_test_CXXFLAGS" = set; then + CXXFLAGS=$ac_save_CXXFLAGS +elif test $ac_cv_prog_cxx_g = yes; then + if test "$GXX" = yes; then + CXXFLAGS="-g -O2" + else + CXXFLAGS="-g" + fi +else + if test "$GXX" = yes; then + CXXFLAGS="-O2" + else + CXXFLAGS= + fi +fi +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + +depcc="$CXX" am_compiler_list= + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 +$as_echo_n "checking dependency style of $depcc... " >&6; } +if ${am_cv_CXX_dependencies_compiler_type+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then + # We make a subdir and do the tests there. Otherwise we can end up + # making bogus files that we don't know about and never remove. For + # instance it was reported that on HP-UX the gcc test will end up + # making a dummy file named 'D' -- because '-MD' means "put the output + # in D". + rm -rf conftest.dir + mkdir conftest.dir + # Copy depcomp to subdir because otherwise we won't find it if we're + # using a relative directory. + cp "$am_depcomp" conftest.dir + cd conftest.dir + # We will build objects and dependencies in a subdirectory because + # it helps to detect inapplicable dependency modes. For instance + # both Tru64's cc and ICC support -MD to output dependencies as a + # side effect of compilation, but ICC will put the dependencies in + # the current directory while Tru64 will put them in the object + # directory. + mkdir sub + + am_cv_CXX_dependencies_compiler_type=none + if test "$am_compiler_list" = ""; then + am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` + fi + am__universal=false + case " $depcc " in #( + *\ -arch\ *\ -arch\ *) am__universal=true ;; + esac + + for depmode in $am_compiler_list; do + # Setup a source with many dependencies, because some compilers + # like to wrap large dependency lists on column 80 (with \), and + # we should not choose a depcomp mode which is confused by this. + # + # We need to recreate these files for each test, as the compiler may + # overwrite some of them when testing with obscure command lines. + # This happens at least with the AIX C compiler. + : > sub/conftest.c + for i in 1 2 3 4 5 6; do + echo '#include "conftst'$i'.h"' >> sub/conftest.c + # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with + # Solaris 10 /bin/sh. + echo '/* dummy */' > sub/conftst$i.h + done + echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf + + # We check with '-c' and '-o' for the sake of the "dashmstdout" + # mode. It turns out that the SunPro C++ compiler does not properly + # handle '-M -o', and we need to detect this. Also, some Intel + # versions had trouble with output in subdirs. + am__obj=sub/conftest.${OBJEXT-o} + am__minus_obj="-o $am__obj" + case $depmode in + gcc) + # This depmode causes a compiler race in universal mode. + test "$am__universal" = false || continue + ;; + nosideeffect) + # After this tag, mechanisms are not by side-effect, so they'll + # only be used when explicitly requested. + if test "x$enable_dependency_tracking" = xyes; then + continue + else + break + fi + ;; + msvc7 | msvc7msys | msvisualcpp | msvcmsys) + # This compiler won't grok '-c -o', but also, the minuso test has + # not run yet. These depmodes are late enough in the game, and + # so weak that their functioning should not be impacted. + am__obj=conftest.${OBJEXT-o} + am__minus_obj= + ;; + none) break ;; + esac + if depmode=$depmode \ + source=sub/conftest.c object=$am__obj \ + depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ + $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ + >/dev/null 2>conftest.err && + grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && + grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && + grep $am__obj sub/conftest.Po > /dev/null 2>&1 && + ${MAKE-make} -s -f confmf > /dev/null 2>&1; then + # icc doesn't choke on unknown options, it will just issue warnings + # or remarks (even with -Werror). So we grep stderr for any message + # that says an option was ignored or not supported. + # When given -MP, icc 7.0 and 7.1 complain thusly: + # icc: Command line warning: ignoring option '-M'; no argument required + # The diagnosis changed in icc 8.0: + # icc: Command line remark: option '-MP' not supported + if (grep 'ignoring option' conftest.err || + grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else + am_cv_CXX_dependencies_compiler_type=$depmode + break + fi + fi + done + + cd .. + rm -rf conftest.dir +else + am_cv_CXX_dependencies_compiler_type=none +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CXX_dependencies_compiler_type" >&5 +$as_echo "$am_cv_CXX_dependencies_compiler_type" >&6; } +CXXDEPMODE=depmode=$am_cv_CXX_dependencies_compiler_type + + if + test "x$enable_dependency_tracking" != xno \ + && test "$am_cv_CXX_dependencies_compiler_type" = gcc3; then + am__fastdepCXX_TRUE= + am__fastdepCXX_FALSE='#' +else + am__fastdepCXX_TRUE='#' + am__fastdepCXX_FALSE= +fi + + +CXXFLAGS="$save_CXXFLAGS"; # Sanity checks, although redundant (useful when debugging this configure.ac)! @@ -4376,6 +4946,307 @@ if eval "$FC -qversion 2>&1 | grep XL 2>/dev/null" ; then # since (as far as it is known to us) -WF, is not used in earlier versions. # More problems could be undocumented yet. fi + +if test "X$CC" == "X" ; then + as_fn_error $? "Problem : No C compiler specified nor found!" "$LINENO" 5 +fi + case $ac_cv_prog_cc_stdc in #( + no) : + ac_cv_prog_cc_c99=no; ac_cv_prog_cc_c89=no ;; #( + *) : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C99" >&5 +$as_echo_n "checking for $CC option to accept ISO C99... " >&6; } +if ${ac_cv_prog_cc_c99+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c99=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +#include +#include +#include + +// Check varargs macros. These examples are taken from C99 6.10.3.5. +#define debug(...) fprintf (stderr, __VA_ARGS__) +#define showlist(...) puts (#__VA_ARGS__) +#define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) +static void +test_varargs_macros (void) +{ + int x = 1234; + int y = 5678; + debug ("Flag"); + debug ("X = %d\n", x); + showlist (The first, second, and third items.); + report (x>y, "x is %d but y is %d", x, y); +} + +// Check long long types. +#define BIG64 18446744073709551615ull +#define BIG32 4294967295ul +#define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) +#if !BIG_OK + your preprocessor is broken; +#endif +#if BIG_OK +#else + your preprocessor is broken; +#endif +static long long int bignum = -9223372036854775807LL; +static unsigned long long int ubignum = BIG64; + +struct incomplete_array +{ + int datasize; + double data[]; +}; + +struct named_init { + int number; + const wchar_t *name; + double average; +}; + +typedef const char *ccp; + +static inline int +test_restrict (ccp restrict text) +{ + // See if C++-style comments work. + // Iterate through items via the restricted pointer. + // Also check for declarations in for loops. + for (unsigned int i = 0; *(text+i) != '\0'; ++i) + continue; + return 0; +} + +// Check varargs and va_copy. +static void +test_varargs (const char *format, ...) +{ + va_list args; + va_start (args, format); + va_list args_copy; + va_copy (args_copy, args); + + const char *str; + int number; + float fnumber; + + while (*format) + { + switch (*format++) + { + case 's': // string + str = va_arg (args_copy, const char *); + break; + case 'd': // int + number = va_arg (args_copy, int); + break; + case 'f': // float + fnumber = va_arg (args_copy, double); + break; + default: + break; + } + } + va_end (args_copy); + va_end (args); +} + +int +main () +{ + + // Check bool. + _Bool success = false; + + // Check restrict. + if (test_restrict ("String literal") == 0) + success = true; + char *restrict newvar = "Another string"; + + // Check varargs. + test_varargs ("s, d' f .", "string", 65, 34.234); + test_varargs_macros (); + + // Check flexible array members. + struct incomplete_array *ia = + malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); + ia->datasize = 10; + for (int i = 0; i < ia->datasize; ++i) + ia->data[i] = i * 1.234; + + // Check named initializers. + struct named_init ni = { + .number = 34, + .name = L"Test wide string", + .average = 543.34343, + }; + + ni.number = 58; + + int dynamic_array[ni.number]; + dynamic_array[ni.number - 1] = 543; + + // work around unused variable warnings + return (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == 'x' + || dynamic_array[ni.number - 1] != 543); + + ; + return 0; +} +_ACEOF +for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -D_STDC_C99= -qlanglvl=extc99 +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c99=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c99" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c99" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c99" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 +$as_echo "$ac_cv_prog_cc_c99" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c99" != xno; then : + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 +else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 +$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +struct stat; +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c89" != xno; then : + ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 +else + ac_cv_prog_cc_stdc=no +fi + +fi + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO Standard C" >&5 +$as_echo_n "checking for $CC option to accept ISO Standard C... " >&6; } + if ${ac_cv_prog_cc_stdc+:} false; then : + $as_echo_n "(cached) " >&6 +fi + + case $ac_cv_prog_cc_stdc in #( + no) : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; #( + '') : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; #( + *) : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_stdc" >&5 +$as_echo "$ac_cv_prog_cc_stdc" >&6; } ;; +esac + +if test "x$ac_cv_prog_cc_stdc" == "xno" ; then + as_fn_error $? "Problem : Need a C99 compiler ! " "$LINENO" 5 +else + C99OPT="$ac_cv_prog_cc_stdc"; +fi ############################################################################### # Suitable MPI compilers detection ############################################################################### @@ -4408,6 +5279,7 @@ if test x"$pac_cv_serial_mpi" == x"yes" ; then FAKEMPI="fakempi.o"; MPIFC="$FC"; MPICC="$CC"; + MPICXX="$CXX"; CXXDEFINES="-DSERIAL_MPI $CXXDEFINES"; else @@ -4929,9 +5801,253 @@ $as_echo "#define HAVE_MPI 1" >>confdefs.h : fi +ac_ext=cpp +ac_cpp='$CXXCPP $CPPFLAGS' +ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_cxx_compiler_gnu + +if test "X$MPICXX" = "X" ; then + # This is our MPICC compiler preference: it will override ACX_MPI's first try. + for ac_prog in mpxlc++ mpiicpc mpicxx +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_MPICXX+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$MPICXX"; then + ac_cv_prog_MPICXX="$MPICXX" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_MPICXX="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +MPICXX=$ac_cv_prog_MPICXX +if test -n "$MPICXX"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MPICXX" >&5 +$as_echo "$MPICXX" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$MPICXX" && break +done + +fi + + + + + + + for ac_prog in mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++ +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_MPICXX+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$MPICXX"; then + ac_cv_prog_MPICXX="$MPICXX" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_MPICXX="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +MPICXX=$ac_cv_prog_MPICXX +if test -n "$MPICXX"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MPICXX" >&5 +$as_echo "$MPICXX" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$MPICXX" && break +done +test -n "$MPICXX" || MPICXX="$CXX" + + acx_mpi_save_CXX="$CXX" + CXX="$MPICXX" + + + +if test x = x"$MPILIBS"; then + ac_fn_cxx_check_func "$LINENO" "MPI_Init" "ac_cv_func_MPI_Init" +if test "x$ac_cv_func_MPI_Init" = xyes; then : + MPILIBS=" " +fi + +fi + +if test x = x"$MPILIBS"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpi" >&5 +$as_echo_n "checking for MPI_Init in -lmpi... " >&6; } +if ${ac_cv_lib_mpi_MPI_Init+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmpi $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char MPI_Init (); +int +main () +{ +return MPI_Init (); + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_link "$LINENO"; then : + ac_cv_lib_mpi_MPI_Init=yes +else + ac_cv_lib_mpi_MPI_Init=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpi_MPI_Init" >&5 +$as_echo "$ac_cv_lib_mpi_MPI_Init" >&6; } +if test "x$ac_cv_lib_mpi_MPI_Init" = xyes; then : + MPILIBS="-lmpi" +fi + +fi +if test x = x"$MPILIBS"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpich" >&5 +$as_echo_n "checking for MPI_Init in -lmpich... " >&6; } +if ${ac_cv_lib_mpich_MPI_Init+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmpich $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char MPI_Init (); +int +main () +{ +return MPI_Init (); + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_link "$LINENO"; then : + ac_cv_lib_mpich_MPI_Init=yes +else + ac_cv_lib_mpich_MPI_Init=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpich_MPI_Init" >&5 +$as_echo "$ac_cv_lib_mpich_MPI_Init" >&6; } +if test "x$ac_cv_lib_mpich_MPI_Init" = xyes; then : + MPILIBS="-lmpich" +fi + +fi + +if test x != x"$MPILIBS"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpi.h" >&5 +$as_echo_n "checking for mpi.h... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_cxx_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + MPILIBS="" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi + +CXX="$acx_mpi_save_CXX" + + + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x = x"$MPILIBS"; then + as_fn_error $? "Cannot find any suitable MPI implementation for C++" "$LINENO" 5 + : +else + +$as_echo "#define HAVE_MPI 1" >>confdefs.h + + : +fi + +ac_ext=${ac_fc_srcext-f} +ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' +ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_fc_compiler_gnu + FC="$MPIFC" ; CC="$MPICC"; +CXX="$MPICXX"; fi ac_ext=c @@ -4977,6 +6093,24 @@ fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional CXXOPT flags should be added (should be invoked only once)" >&5 +$as_echo_n "checking whether additional CXXOPT flags should be added (should be invoked only once)... " >&6; } + +# Check whether --with-cxxopt was given. +if test "${with_cxxopt+set}" = set; then : + withval=$with_cxxopt; +CXXOPT="${withval} ${CXXOPT}" +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: CXXOPT = ${CXXOPT}" >&5 +$as_echo "CXXOPT = ${CXXOPT}" >&6; } + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional FCOPT flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional FCOPT flags should be added (should be invoked only once)... " >&6; } @@ -5050,6 +6184,24 @@ fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional CXXLIBS flags should be added (should be invoked only once)" >&5 +$as_echo_n "checking whether additional CXXLIBS flags should be added (should be invoked only once)... " >&6; } + +# Check whether --with-cxxlibs was given. +if test "${with_cxxlibs+set}" = set; then : + withval=$with_cxxlibs; +CXXLIBS="${withval} ${CXXLIBS}" +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: CXXLIBS = ${CXXLIBS}" >&5 +$as_echo "CXXLIBS = ${CXXLIBS}" >&6; } + +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional LIBRARYPATH flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional LIBRARYPATH flags should be added (should be invoked only once)... " >&6; } @@ -5126,6 +6278,23 @@ fi +# Check if we need extra libs (e.g. for OpenMPI) +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking Extra mpicxx libs?" >&5 +$as_echo_n "checking Extra mpicxx libs?... " >&6; } +xtrlibs=`mpicxx --showme:link 2>/dev/null`; +if (( $? == 0 )) +then + EXTRA_LIBS="$EXTRA_LIBS $xtrlibs"; + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $xtrlibs" >&5 +$as_echo "$xtrlibs" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none" >&5 +$as_echo "none" >&6; } +fi + + + + ############################################################################### # Sanity checks, although redundant (useful when debugging this configure.ac)! ############################################################################### @@ -5978,6 +7147,36 @@ if test "X$CCOPT" == "X" ; then fi fi #CFLAGS="${CCOPT}" +if test "X$CXXOPT" == "X" ; then + CXXOPT="$CXXFLAGS"; +fi +if test "X$CXXOPT" == "X" ; then + if test "X$psblas_cv_fc" == "Xgcc" ; then + # note that no space should be placed around the equality symbol in assignements + # Note : 'native' is valid _only_ on GCC/x86 (32/64 bits) + CXXOPT="-g -O3 $CXXOPT" + + elif test "X$psblas_cv_fc" == X"xlf" ; then + # XL compiler : consider using -qarch=auto + CXXOPT="-O3 -qarch=auto $CXXOPT" + elif test "X$psblas_cv_fc" == X"ifc" ; then + # other compilers .. + CXXOPT="-O3 $CXXOPT" + elif test "X$psblas_cv_fc" == X"pg" ; then + # other compilers .. + CXXCOPT="-fast $CXXOPT" + # NOTE : PG & Sun use -fast instead -O3 + elif test "X$psblas_cv_fc" == X"sun" ; then + # other compilers .. + CXXOPT="-fast $CXXOPT" + elif test "X$psblas_cv_fc" == X"cray" ; then + CXXOPT="-O3 $CXXOPT" + MPICXX="CC" + else + CXXOPT="-g -O3 $CXXOPT" + fi +fi + # Honor FCFLAGS if they were specified explicitly, but --with-fcopt take precedence if test "X$FCOPT" == "X" ; then @@ -6026,7 +7225,8 @@ fi ############################################################################## FC=${FC} CC=${CC} -MPCC=${MPICC} +CXX=${CXX} +CCOPT="$CCOPT $C99OPT" ############################################################################## @@ -6178,6 +7378,61 @@ fi if test "X$FLINK" == "X" ; then FLINK=${MPF90} fi +# Custom test : do we have a module or include for MPI Fortran interface? +if test x"$pac_cv_serial_mpi" == x"yes" ; then + FDEFINES="$psblas_cv_define_prepend-DSERIAL_MPI $psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; +else + PAC_FORTRAN_CHECK_HAVE_MPI_MOD_F08() + if test x"$pac_cv_mpi_f08" == x"yes" ; then + FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; + else + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran MPI mod" >&5 +$as_echo_n "checking for Fortran MPI mod... " >&6; } + ac_ext=${ac_fc_srcext-f} +ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' +ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_fc_compiler_gnu + + ac_exeext='' + ac_ext='F90' + ac_fc=${MPIFC-$FC}; + cat > conftest.$ac_ext <<_ACEOF + + program test + use mpi + end program test +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES" +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + FDEFINES="$psblas_cv_define_prepend-DMPI_H $FDEFINES" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + fi +fi + +FLINK="$MPIFC" +PAC_ARG_OPENMP() +if test x"$pac_cv_openmp" == x"yes" ; then + FDEFINES="$psblas_cv_define_prepend-DOPENMP $FDEFINES"; + CDEFINES="-DOPENMP $CDEFINES"; + FCOPT="$FCOPT $pac_cv_openmp_fcopt"; + CCOPT="$CCOPT $pac_cv_openmp_ccopt"; + FLINK="$FLINK $pac_cv_openmp_fcopt"; +fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working installation of PSBLAS" >&5 $as_echo_n "checking for working installation of PSBLAS... " >&6; } @@ -9078,6 +10333,8 @@ rm -f core conftest.err conftest.$ac_objext \ if test "x$pac_sludist_lib_ok" == "xno" ; then SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib"; LIBS="$SLUDIST_LIBS -lm $save_LIBS"; + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc_dist in $SLUDIST_LIBS" >&5 +$as_echo_n "checking for superlu_malloc_dist in $SLUDIST_LIBS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -9108,6 +10365,8 @@ rm -f core conftest.err conftest.$ac_objext \ if test "x$pac_sludist_lib_ok" == "xno" ; then SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib64"; LIBS="$SLUDIST_LIBS -lm $save_LIBS"; + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc_dist in $SLUDIST_LIBS" >&5 +$as_echo_n "checking for superlu_malloc_dist in $SLUDIST_LIBS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -9135,8 +10394,8 @@ fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok" >&5 -$as_echo "$pac_sludist_lib_ok" >&6; } + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok $SLUDIST_LIBS" >&5 +$as_echo "$pac_sludist_lib_ok $SLUDIST_LIBS" >&6; } fi if test "x$pac_sludist_lib_ok" == "xyes" ; then @@ -9278,14 +10537,11 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu if test "x$amg4psblas_cv_have_superludist" == "xyes" ; then - pac_sludist_version="$amg4psblas_cv_superludist_major"; - if (($amg4psblas_cv_superludist_major==6)); then - if (($amg4psblas_cv_superludist_minor>=3)); then - pac_sludist_version="63"; - fi - fi + pac_sludist_version="$amg4psblas_cv_superludist_major$amg4psblas_cv_superludist_minor"; + { $as_echo "$as_me:${as_lineno-$LINENO}: Configuring with SuperLU_DIST version flag $pac_sludist_version" >&5 +$as_echo "$as_me: Configuring with SuperLU_DIST version flag $pac_sludist_version" >&6;} SLUDIST_FLAGS="" - SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_$pac_sludist_version $SLUDIST_INCLUDES" + SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_="$pac_sludist_version" $SLUDIST_INCLUDES" FDEFINES="$amg_cv_define_prepend-DHAVE_SLUDIST_ $FDEFINES" else SLUDIST_FLAGS="" @@ -9513,6 +10769,10 @@ if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi +if test -z "${am__fastdepCXX_TRUE}" && test -z "${am__fastdepCXX_FALSE}"; then + as_fn_error $? "conditional \"am__fastdepCXX\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 @@ -10598,7 +11858,9 @@ $as_echo X/"$am_mf" | { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "Something went wrong bootstrapping makefile fragments - for automatic dependency tracking. Try re-running configure with the + for automatic dependency tracking. If GNU make was not used, consider + re-running the configure script with MAKE=\"gmake\" (or whatever is + necessary). You can also try re-running configure with the '--disable-dependency-tracking' option to at least be able to build the package (albeit without support for automatic dependency tracking). See \`config.log' for more details" "$LINENO" 5; } diff --git a/configure.ac b/configure.ac index 8cd0797b..03fb8bd1 100755 --- a/configure.ac +++ b/configure.ac @@ -133,6 +133,9 @@ FCFLAGS="$save_FCFLAGS"; save_CFLAGS="$CFLAGS"; AC_PROG_CC([cc xlc pgcc icc gcc ]) CFLAGS="$save_CFLAGS"; +save_CXXFLAGS="$CXXFLAGS"; +AC_PROG_CXX([CC xlc++ icpc g++]) +CXXFLAGS="$save_CXXFLAGS"; dnl AC_PROG_CXX dnl AC_PROG_F90 doesn't exist, at the time of writing this ! @@ -158,6 +161,16 @@ if eval "$FC -qversion 2>&1 | grep XL 2>/dev/null" ; then # since (as far as it is known to us) -WF, is not used in earlier versions. # More problems could be undocumented yet. fi + +if test "X$CC" == "X" ; then + AC_MSG_ERROR([Problem : No C compiler specified nor found!]) +fi +AC_PROG_CC_STDC() +if test "x$ac_cv_prog_cc_stdc" == "xno" ; then + AC_MSG_ERROR([Problem : Need a C99 compiler ! ]) +else + C99OPT="$ac_cv_prog_cc_stdc"; +fi ############################################################################### # Suitable MPI compilers detection ############################################################################### @@ -171,6 +184,7 @@ if test x"$pac_cv_serial_mpi" == x"yes" ; then FAKEMPI="fakempi.o"; MPIFC="$FC"; MPICC="$CC"; + MPICXX="$CXX"; CXXDEFINES="-DSERIAL_MPI $CXXDEFINES"; else @@ -190,9 +204,17 @@ if test "X$MPIFC" = "X" ; then fi ACX_MPI([], [AC_MSG_ERROR([[Cannot find any suitable MPI implementation for Fortran]])]) +AC_LANG([C++]) +if test "X$MPICXX" = "X" ; then + # This is our MPICC compiler preference: it will override ACX_MPI's first try. + AC_CHECK_PROGS([MPICXX],[mpxlc++ mpiicpc mpicxx]) +fi +ACX_MPI([], [AC_MSG_ERROR([[Cannot find any suitable MPI implementation for C++]])]) +AC_LANG([Fortran]) FC="$MPIFC" ; CC="$MPICC"; +CXX="$MPICXX"; fi AC_LANG([C]) @@ -217,10 +239,12 @@ fi dnl NOTE : no spaces before the comma, and no brackets before the second argument! PAC_ARG_WITH_FLAGS(ccopt,CCOPT) +PAC_ARG_WITH_FLAGS(cxxopt,CXXOPT) PAC_ARG_WITH_FLAGS(fcopt,FCOPT) PAC_ARG_WITH_LIBS PAC_ARG_WITH_FLAGS(clibs,CLIBS) PAC_ARG_WITH_FLAGS(flibs,FLIBS) +PAC_ARG_WITH_FLAGS(cxxlibs,CXXLIBS) dnl candidates for removal: PAC_ARG_WITH_FLAGS(library-path,LIBRARYPATH) @@ -230,6 +254,20 @@ PAC_ARG_WITH_FLAGS(module-path,MODULE_PATH) # we just gave the user the chance to append values to these variables PAC_ARG_WITH_EXTRA_LIBS +# Check if we need extra libs (e.g. for OpenMPI) +AC_MSG_CHECKING([Extra mpicxx libs?]) +xtrlibs=`mpicxx --showme:link 2>/dev/null`; +if (( $? == 0 )) +then + EXTRA_LIBS="$EXTRA_LIBS $xtrlibs"; + AC_MSG_RESULT([$xtrlibs]) +else + AC_MSG_RESULT([none]) +fi + + + + ############################################################################### # Sanity checks, although redundant (useful when debugging this configure.ac)! ############################################################################### @@ -395,6 +433,36 @@ if test "X$CCOPT" == "X" ; then fi fi #CFLAGS="${CCOPT}" +if test "X$CXXOPT" == "X" ; then + CXXOPT="$CXXFLAGS"; +fi +if test "X$CXXOPT" == "X" ; then + if test "X$psblas_cv_fc" == "Xgcc" ; then + # note that no space should be placed around the equality symbol in assignements + # Note : 'native' is valid _only_ on GCC/x86 (32/64 bits) + CXXOPT="-g -O3 $CXXOPT" + + elif test "X$psblas_cv_fc" == X"xlf" ; then + # XL compiler : consider using -qarch=auto + CXXOPT="-O3 -qarch=auto $CXXOPT" + elif test "X$psblas_cv_fc" == X"ifc" ; then + # other compilers .. + CXXOPT="-O3 $CXXOPT" + elif test "X$psblas_cv_fc" == X"pg" ; then + # other compilers .. + CXXCOPT="-fast $CXXOPT" + # NOTE : PG & Sun use -fast instead -O3 + elif test "X$psblas_cv_fc" == X"sun" ; then + # other compilers .. + CXXOPT="-fast $CXXOPT" + elif test "X$psblas_cv_fc" == X"cray" ; then + CXXOPT="-O3 $CXXOPT" + MPICXX="CC" + else + CXXOPT="-g -O3 $CXXOPT" + fi +fi + # Honor FCFLAGS if they were specified explicitly, but --with-fcopt take precedence if test "X$FCOPT" == "X" ; then @@ -443,7 +511,8 @@ fi ############################################################################## FC=${FC} CC=${CC} -MPCC=${MPICC} +CXX=${CXX} +CCOPT="$CCOPT $C99OPT" ############################################################################## @@ -478,6 +547,30 @@ fi if test "X$FLINK" == "X" ; then FLINK=${MPF90} fi +# Custom test : do we have a module or include for MPI Fortran interface? +if test x"$pac_cv_serial_mpi" == x"yes" ; then + FDEFINES="$psblas_cv_define_prepend-DSERIAL_MPI $psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; +else + PAC_FORTRAN_CHECK_HAVE_MPI_MOD_F08() + if test x"$pac_cv_mpi_f08" == x"yes" ; then +dnl FDEFINES="$psblas_cv_define_prepend-DMPI_MOD_F08 $FDEFINES"; + FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; + else + PAC_FORTRAN_CHECK_HAVE_MPI_MOD( + [FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"], + [FDEFINES="$psblas_cv_define_prepend-DMPI_H $FDEFINES"]) + fi +fi + +FLINK="$MPIFC" +PAC_ARG_OPENMP() +if test x"$pac_cv_openmp" == x"yes" ; then + FDEFINES="$psblas_cv_define_prepend-DOPENMP $FDEFINES"; + CDEFINES="-DOPENMP $CDEFINES"; + FCOPT="$FCOPT $pac_cv_openmp_fcopt"; + CCOPT="$CCOPT $pac_cv_openmp_ccopt"; + FLINK="$FLINK $pac_cv_openmp_fcopt"; +fi PAC_FORTRAN_HAVE_PSBLAS([AC_MSG_RESULT([yes.])], [AC_MSG_ERROR([no. Could not find working version of PSBLAS.])]) @@ -693,14 +786,10 @@ fi PAC_CHECK_SUPERLUDIST() if test "x$amg4psblas_cv_have_superludist" == "xyes" ; then - pac_sludist_version="$amg4psblas_cv_superludist_major"; - if (($amg4psblas_cv_superludist_major==6)); then - if (($amg4psblas_cv_superludist_minor>=3)); then - pac_sludist_version="63"; - fi - fi + pac_sludist_version="$amg4psblas_cv_superludist_major$amg4psblas_cv_superludist_minor"; + AC_MSG_NOTICE([Configuring with SuperLU_DIST version flag $pac_sludist_version]) SLUDIST_FLAGS="" - SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_$pac_sludist_version $SLUDIST_INCLUDES" + SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_="$pac_sludist_version" $SLUDIST_INCLUDES" FDEFINES="$amg_cv_define_prepend-DHAVE_SLUDIST_ $FDEFINES" else SLUDIST_FLAGS="" diff --git a/configure_n b/configure_n index 42999ca0..08c0b135 100755 --- a/configure_n +++ b/configure_n @@ -753,6 +753,7 @@ infodir docdir oldincludedir includedir +runstatedir localstatedir sharedstatedir sysconfdir @@ -877,6 +878,7 @@ datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' @@ -1129,6 +1131,15 @@ do | -silent | --silent | --silen | --sile | --sil) silent=yes ;; + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1266,7 +1277,7 @@ fi for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir + libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1419,6 +1430,7 @@ Fine tuning of the installation directories: --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] @@ -8087,6 +8099,44 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran ISO_C_BINDING module" >&5 +$as_echo_n "checking support for Fortran ISO_C_BINDING module... " >&6; } + ac_ext=${ac_fc_srcext-f} +ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' +ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_fc_compiler_gnu + + ac_exeext='' + ac_ext='f90' + ac_fc=${MPIFC-$FC}; + cat > conftest.$ac_ext <<_ACEOF + +program conftest + use iso_c_binding +end program conftest +_ACEOF +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + : +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + as_fn_error $? "Sorry, cannot build PSBLAS without support for ISO_C_BINDING. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking support for ISO_FORTRAN_ENV" >&5 $as_echo_n "checking support for ISO_FORTRAN_ENV... " >&6; } ac_ext=${ac_fc_srcext-f} @@ -10706,6 +10756,8 @@ rm -f core conftest.err conftest.$ac_objext \ if test "x$pac_sludist_lib_ok" == "xno" ; then SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib"; LIBS="$SLUDIST_LIBS -lm $save_LIBS"; + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc_dist in $SLUDIST_LIBS" >&5 +$as_echo_n "checking for superlu_malloc_dist in $SLUDIST_LIBS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -10736,6 +10788,8 @@ rm -f core conftest.err conftest.$ac_objext \ if test "x$pac_sludist_lib_ok" == "xno" ; then SLUDIST_LIBS="$amg4psblas_cv_superludist -L$amg4psblas_cv_superludistdir/lib64"; LIBS="$SLUDIST_LIBS -lm $save_LIBS"; + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for superlu_malloc_dist in $SLUDIST_LIBS" >&5 +$as_echo_n "checking for superlu_malloc_dist in $SLUDIST_LIBS... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -10763,8 +10817,8 @@ fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok" >&5 -$as_echo "$pac_sludist_lib_ok" >&6; } + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_sludist_lib_ok $SLUDIST_LIBS" >&5 +$as_echo "$pac_sludist_lib_ok $SLUDIST_LIBS" >&6; } fi if test "x$pac_sludist_lib_ok" == "xyes" ; then @@ -10906,14 +10960,11 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu if test "x$amg4psblas_cv_have_superludist" == "xyes" ; then - pac_sludist_version="$amg4psblas_cv_superludist_major"; - if (($amg4psblas_cv_superludist_major==6)); then - if (($amg4psblas_cv_superludist_minor>=3)); then - pac_sludist_version="63"; - fi - fi + pac_sludist_version="$amg4psblas_cv_superludist_major$amg4psblas_cv_superludist_minor"; + { $as_echo "$as_me:${as_lineno-$LINENO}: Configuring with SuperLU_DIST version flag $pac_sludist_version" >&5 +$as_echo "$as_me: Configuring with SuperLU_DIST version flag $pac_sludist_version" >&6;} SLUDIST_FLAGS="" - SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_$pac_sludist_version $SLUDIST_INCLUDES" + SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_="$pac_sludist_version" $SLUDIST_INCLUDES" FDEFINES="$amg_cv_define_prepend-DHAVE_SLUDIST_ $FDEFINES" else SLUDIST_FLAGS="" @@ -12275,7 +12326,9 @@ $as_echo X/"$am_mf" | { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "Something went wrong bootstrapping makefile fragments - for automatic dependency tracking. Try re-running configure with the + for automatic dependency tracking. If GNU make was not used, consider + re-running the configure script with MAKE=\"gmake\" (or whatever is + necessary). You can also try re-running configure with the '--disable-dependency-tracking' option to at least be able to build the package (albeit without support for automatic dependency tracking). See \`config.log' for more details" "$LINENO" 5; } diff --git a/configure_n.ac b/configure_n.ac index bdf31b21..da5ee5e7 100755 --- a/configure_n.ac +++ b/configure_n.ac @@ -673,6 +673,12 @@ PAC_FORTRAN_TEST_VOLATILE( [AC_MSG_ERROR([Sorry, cannot build PSBLAS without support for VOLATILE])] ) +PAC_FORTRAN_TEST_ISO_C_BIND( + [], + [AC_MSG_ERROR([Sorry, cannot build PSBLAS without support for ISO_C_BINDING. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8.])] +) + PAC_FORTRAN_TEST_ISO_FORTRAN_ENV( [], [AC_MSG_ERROR([Sorry, cannot build PSBLAS without support for ISO_FORTRAN_ENV])] @@ -856,14 +862,10 @@ fi PAC_CHECK_SUPERLUDIST() if test "x$amg4psblas_cv_have_superludist" == "xyes" ; then - pac_sludist_version="$amg4psblas_cv_superludist_major"; - if (($amg4psblas_cv_superludist_major==6)); then - if (($amg4psblas_cv_superludist_minor>=3)); then - pac_sludist_version="63"; - fi - fi + pac_sludist_version="$amg4psblas_cv_superludist_major$amg4psblas_cv_superludist_minor"; + AC_MSG_NOTICE([Configuring with SuperLU_DIST version flag $pac_sludist_version]) SLUDIST_FLAGS="" - SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_$pac_sludist_version $SLUDIST_INCLUDES" + SLUDIST_FLAGS="-DHave_SLUDist_ -DSLUD_VERSION_="$pac_sludist_version" $SLUDIST_INCLUDES" FDEFINES="$amg_cv_define_prepend-DHAVE_SLUDIST_ $FDEFINES" else SLUDIST_FLAGS="" diff --git a/docs/amg4psblas_1.0-guide.pdf b/docs/amg4psblas_1.0-guide.pdf index 4362844f..b3c4f559 100644 Binary files a/docs/amg4psblas_1.0-guide.pdf and b/docs/amg4psblas_1.0-guide.pdf differ diff --git a/docs/html/userhtmlsu3.html b/docs/html/userhtmlsu3.html index 98612f6f..4c9d0541 100644 --- a/docs/html/userhtmlsu3.html +++ b/docs/html/userhtmlsu3.html @@ -4228,9 +4228,9 @@ class="cmtt-12">github.com/sfilipponepsctoolkit/amg4psblaspsctoolkit/issues>. diff --git a/docs/html/userhtmlsu4.html b/docs/html/userhtmlsu4.html index 8146ab12..65623d3c 100644 --- a/docs/html/userhtmlsu4.html +++ b/docs/html/userhtmlsu4.html @@ -36,8 +36,8 @@ class="cmr-12">If you find any bugs in our codes, please report them through our on
https://github.com/psctoolkit/amg4psblas/issues
https://github.com/psctoolkit/psctoolkit/issues

To enable us to track the bug, please provide a log from the failing application, the diff --git a/docs/html/userhtmlsu6.html b/docs/html/userhtmlsu6.html index 41956e96..18b849f3 100644 --- a/docs/html/userhtmlsu6.html +++ b/docs/html/userhtmlsu6.html @@ -79,7 +79,8 @@ class="cmr-12">found in the example program file amg_dexample_ml.f90, in the directory samples/simple/fileread samples/simple/fileread of the AMG4PSBLAS implementation (see Section for details). If these versions are installed, the corresponding codes are available in samples/simple/fileread/samples/simple/fileread. diff --git a/docs/html/userhtmlsu7.html b/docs/html/userhtmlsu7.html index 57eae31c..29573365 100644 --- a/docs/html/userhtmlsu7.html +++ b/docs/html/userhtmlsu7.html @@ -143,7 +143,7 @@ class="cmr-12">GPU environment

-

+

   call desc_a%cnv(mold=igmold)
   call a%cscnv(info,mold=agmold)
@@ -167,7 +167,7 @@ class="cmr-12">GPU environment
   stop
  
-

+


Listing 7: setup of a GPU-enabled test program part three.
@@ -175,25 +175,30 @@ class="content">setup of a GPU-enabled test program part three.

It is very important to employ solvers that are suited to the GPU, i.e. solvers that +

It is very important to employ smoothers and coarsest solvers that are suited to the do NOT employ triangular system solve kernels. Solvers that satisfy this constraint +class="cmr-12">GPU, i.e. methods that do NOT employ triangular system solve kernels. Methods that include: +class="cmr-12">satisfy this constraint include:

  • JACOBI
  • BJAC with the following methods on the local blocks: +
      +
    • INVK -
      • -
    • +
    • INVT -
      • -
    • +
    • AINV
    -

+

and their ℓ1 . +Report bugs to . diff --git a/docs/src/gettingstarted.tex b/docs/src/gettingstarted.tex index 04b07490..956ca995 100644 --- a/docs/src/gettingstarted.tex +++ b/docs/src/gettingstarted.tex @@ -129,7 +129,7 @@ relevant data structures, performed through the PSBLAS routines for sparse matrix and vector management, is not reported here for the sake of conciseness. The complete code can be found in the example program file \verb|amg_dexample_ml.f90|, -in the directory \verb|samples/simple/fileread| of the AMG4PSBLAS implementation (see +in the directory \verb|samples/simple/file|\-\verb|read| of the AMG4PSBLAS implementation (see Section~\ref{sec:ex_and_test}). A sample test problem along with the relevant input data is available in \verb|samples/simple/fileread/runs|. For details on the use of the PSBLAS routines, see the PSBLAS User's @@ -139,7 +139,7 @@ The setup and application of the default multilevel preconditioner for the real single precision and the complex, single and double precision, versions are obtained with straightforward modifications of the previous example (see Section~\ref{sec:userinterface} for details). If these versions are installed, -the corresponding codes are available in \verb|samples/simple/fileread/|. +the corresponding codes are available in \verb|samples/simple/file|\-\verb|read|. \begin{listing}[tbp] \begin{center} @@ -539,7 +539,8 @@ Krylov method. At the end of the code, we close the GPU environment call prec%allocate_wrk(info) t1 = psb_wtime() call psb_krylov(s_choice%kmethd,a,prec,b,x,s_choice%eps,& - & desc_a,info,itmax=s_choice%itmax,iter=iter,err=err,itrace=s_choice%itrace,& + & desc_a,info,itmax=s_choice%itmax,iter=iter,err=err,& + & itrace=s_choice%itrace,& & istop=s_choice%istopc,irst=s_choice%irst) call prec%deallocate_wrk(info) call psb_barrier(ctxt) @@ -588,15 +589,18 @@ Krylov method. At the end of the code, we close the GPU environment \caption{setup of a GPU-enabled test program part three.\label{fig:gpu-ex3}} \end{listing} -It is very important to employ solvers that are suited -to the GPU, i.e. solvers that do NOT employ triangular -system solve kernels. Solvers that satisfy this constraint include: +It is very important to employ smoothers and coarsest solvers that are suited +to the GPU, i.e. methods that do NOT employ triangular +system solve kernels. Methods that satisfy this constraint include: \begin{itemize} \item \verb|JACOBI| +\item \verb|BJAC| with the following methods on the local blocks: +\begin{itemize} \item \verb|INVK| \item \verb|INVT| \item \verb|AINV| \end{itemize} +\end{itemize} and their $\ell_1$ variants. %%% Local Variables: diff --git a/examples/gpu/amg_dexample_gpu.f90 b/examples/gpu/amg_dexample_gpu.f90 index 142dabe0..13fc343e 100644 --- a/examples/gpu/amg_dexample_gpu.f90 +++ b/examples/gpu/amg_dexample_gpu.f90 @@ -39,23 +39,18 @@ ! ! This sample program solves a linear system obtained by discretizing a ! PDE with Dirichlet BCs. The solver is CG, coupled with one of the -! following multi-level preconditioner, as explained in Section 4.1 of +! following multi-level preconditioner, as explained in Section 4.2 of ! the AMG4PSBLAS User's and Reference Guide: ! -! - choice = 1, the default multi-level preconditioner solver, i.e., -! V-cycle with decoupled smoothed aggregation, 1 hybrid forward/backward -! GS sweep as pre/post-smoother and UMFPACK as coarsest-level -! solver (Sec. 4.1, Listing 1) +! - choice = 1, a V-cycle with decoupled smoothed aggregation, 4 Jacobi +! sweeps as pre/post-smoother and 8 Jacobi sweeps as coarsest-level +! solver with replicated coarsest matrix ! -! - choice = 2, a V-cycle preconditioner with 1 block-Jacobi sweep -! (with ILU(0) on the blocks) as pre- and post-smoother, and 8 block-Jacobi -! sweeps (with ILU(0) on the blocks) as coarsest-level solver (Sec. 4.1, Listing 2) -! -! - choice = 3, W-cycle preconditioner based on the coupled aggregation relying -! on matching, with maximum size of aggregates equal to 8 and smoothed prolongators, -! 2 hybrid forward/backward GS sweeps as pre/post-smoother, a distributed coarsest -! matrix, and preconditioned Flexible Conjugate Gradient as coarsest-level solver -! (Sec. 4.1, Listing 3) +! - choice = 2, a W-cycle based on the coupled aggregation relying on matching, +! with maximum size of aggregates equal to 8 and smoothed prolongators, +! 2 sweeps of Block-Jacobi ipre/post-smoother using approximate inverse INVK and +! 4 sweeps of Block-Jacobi with INVK as coarsest-level solver on distributed +! coarsest matrix ! ! The matrix and the rhs are read from files (if an rhs is not available, the ! unit rhs is set). @@ -183,8 +178,9 @@ program amg_dexample_gpu case(1) - ! initialize a V-cycle preconditioner with 4 Jacobi sweep - ! and 8 Jacobi sweeps as coarsest-level solver + ! initialize a V-cycle preconditioner, relying on decoupled smoothed aggregation + ! with 4 Jacobi sweeps as pre/post-smoother + ! and 8 Jacobi sweeps as coarsest-level solver on replicated coarsest matrix call P%init(ctxt,'ML',info) call P%set('SMOOTHER_TYPE','JACOBI',info) @@ -195,19 +191,22 @@ program amg_dexample_gpu case(2) - ! initialize a V-cycle preconditioner based on the coupled aggregation relying on matching, + ! initialize a W-cycle preconditioner based on the coupled aggregation relying on matching, ! with maximum size of aggregates equal to 8 and smoothed prolongators, - ! Block-Jacobi smoother using approximate inverse INVK and - ! and 4 sweeps of INVK on he coarsest level + ! 2 sweeps of Block-Jacobi pre/post-smoother using approximate inverse INVK and + ! 4 sweeps of Block-Jacobi with INVK on the coarsest level distributed matrix call P%init(ctxt,'ML',info) call P%set('PAR_AGGR_ALG','COUPLED',info) call P%set('AGGR_TYPE','MATCHBOXP',info) call P%set('AGGR_SIZE',8,info) call P%set('ML_CYCLE','WCYCLE',info) + call P%set('SMOOTHER_TYPE','BJAC',info) call P%set('SMOOTHER_SWEEPS',2,info) call P%set('SUB_SOLVE','INVK',info) - call P%set('COARSE_SOLVE','INVK',info) + call P%set('COARSE_SOLVE','BJAC',info) + call P%set('COARSE_SUBSOLVE','INVK',info) + call P%set('COARSE_SWEEPS',4,info) call P%set('COARSE_MAT','DIST',info) kmethod = 'CG' diff --git a/samples/advanced/fileread/amg_cf_sample.f90 b/samples/advanced/fileread/amg_cf_sample.f90 index c881fb40..e18079ae 100644 --- a/samples/advanced/fileread/amg_cf_sample.f90 +++ b/samples/advanced/fileread/amg_cf_sample.f90 @@ -676,8 +676,9 @@ contains call read_data(prec%aggr_prol,inp_unit) ! aggregation type call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -685,7 +686,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver diff --git a/samples/advanced/fileread/amg_df_sample.f90 b/samples/advanced/fileread/amg_df_sample.f90 index a43a654e..8c29eff8 100644 --- a/samples/advanced/fileread/amg_df_sample.f90 +++ b/samples/advanced/fileread/amg_df_sample.f90 @@ -676,8 +676,9 @@ contains call read_data(prec%aggr_prol,inp_unit) ! aggregation type call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -685,7 +686,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver diff --git a/samples/advanced/fileread/amg_sf_sample.f90 b/samples/advanced/fileread/amg_sf_sample.f90 index 650ca0ea..e195d4ff 100644 --- a/samples/advanced/fileread/amg_sf_sample.f90 +++ b/samples/advanced/fileread/amg_sf_sample.f90 @@ -676,8 +676,9 @@ contains call read_data(prec%aggr_prol,inp_unit) ! aggregation type call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -685,7 +686,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver diff --git a/samples/advanced/fileread/amg_zf_sample.f90 b/samples/advanced/fileread/amg_zf_sample.f90 index 7ea18464..6d7e6f9c 100644 --- a/samples/advanced/fileread/amg_zf_sample.f90 +++ b/samples/advanced/fileread/amg_zf_sample.f90 @@ -676,8 +676,9 @@ contains call read_data(prec%aggr_prol,inp_unit) ! aggregation type call read_data(prec%par_aggr_alg,inp_unit) ! parallel aggregation alg call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -685,7 +686,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver diff --git a/samples/advanced/fileread/runs/amg_cfs.inp b/samples/advanced/fileread/runs/amg_cfs.inp index 195be4a4..44ca86bf 100644 --- a/samples/advanced/fileread/runs/amg_cfs.inp +++ b/samples/advanced/fileread/runs/amg_cfs.inp @@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED DEC ! Parallel aggregation: DEC, SYMDEC NATURAL ! Ordering of aggregation NATURAL DEGREE -FILTER ! Filtering of matrix: FILTER NOFILTER -1.5 ! Coarsening ratio, if < 0 use library default +FILTER ! Filtering of matrix: FILTER NOFILTER +-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 -2 ! Number of thresholds in vector, next line ignored if <= 0 0.05 0.025 ! Thresholds --0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 %%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%% SLU ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC SLU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU diff --git a/samples/advanced/fileread/runs/amg_dfs.inp b/samples/advanced/fileread/runs/amg_dfs.inp index 221dfecd..9e0606b2 100644 --- a/samples/advanced/fileread/runs/amg_dfs.inp +++ b/samples/advanced/fileread/runs/amg_dfs.inp @@ -1,8 +1,8 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. -mld_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or -mld_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html +amg_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or +amg_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html NONE ! Initial guess -mld_sol.mtx ! Reference solution +amg_sol.mtx ! Reference solution MM ! File format: MatrixMarket or Harwell-Boeing CSR ! Storage format: CSR COO JAD GRAPH ! PART (partition method): BLOCK GRAPH @@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED DEC ! Parallel aggregation: DEC, SYMDEC NATURAL ! Ordering of aggregation NATURAL DEGREE -FILTER ! Filtering of matrix: FILTER NOFILTER -1.5 ! Coarsening ratio, if < 0 use library default +FILTER ! Filtering of matrix: FILTER NOFILTER +-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 -2 ! Number of thresholds in vector, next line ignored if <= 0 0.05 0.025 ! Thresholds --0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 %%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%% UMF ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC UMF ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU diff --git a/samples/advanced/fileread/runs/amg_sfs.inp b/samples/advanced/fileread/runs/amg_sfs.inp index d7388521..a73415ab 100644 --- a/samples/advanced/fileread/runs/amg_sfs.inp +++ b/samples/advanced/fileread/runs/amg_sfs.inp @@ -1,8 +1,8 @@ %%%%%%%%%%% General arguments % Lines starting with % are ignored. -mld_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or -mld_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html +amg_mat.mtx ! Other matrices from: http://math.nist.gov/MatrixMarket/ or +amg_rhs.mtx ! rhs ! http://www.cise.ufl.edu/research/sparse/matrices/index.html NONE ! Initial guess -mld_sol.mtx ! Reference solution +amg_sol.mtx ! Reference solution MM ! File format: MatrixMarket or Harwell-Boeing CSR ! Storage format: CSR COO JAD GRAPH ! PART (partition method): BLOCK GRAPH @@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED DEC ! Parallel aggregation: DEC, SYMDEC NATURAL ! Ordering of aggregation NATURAL DEGREE -FILTER ! Filtering of matrix: FILTER NOFILTER -1.5 ! Coarsening ratio, if < 0 use library default +FILTER ! Filtering of matrix: FILTER NOFILTER +-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 -2 ! Number of thresholds in vector, next line ignored if <= 0 0.05 0.025 ! Thresholds --0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 %%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%% SLU ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC SLU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU diff --git a/samples/advanced/fileread/runs/amg_zfs.inp b/samples/advanced/fileread/runs/amg_zfs.inp index d0c48861..1868d64c 100644 --- a/samples/advanced/fileread/runs/amg_zfs.inp +++ b/samples/advanced/fileread/runs/amg_zfs.inp @@ -41,11 +41,11 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED DEC ! Parallel aggregation: DEC, SYMDEC NATURAL ! Ordering of aggregation NATURAL DEGREE -FILTER ! Filtering of matrix: FILTER NOFILTER -1.5 ! Coarsening ratio, if < 0 use library default +FILTER ! Filtering of matrix: FILTER NOFILTER +-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 -2 ! Number of thresholds in vector, next line ignored if <= 0 0.05 0.025 ! Thresholds --0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 %%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%% UMF ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC UMF ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU diff --git a/samples/advanced/pdegen/Makefile b/samples/advanced/pdegen/Makefile index 79c2d89e..0720b6f3 100644 --- a/samples/advanced/pdegen/Makefile +++ b/samples/advanced/pdegen/Makefile @@ -44,7 +44,7 @@ check: all clean: /bin/rm -f data_input.o *.o *$(.mod)\ - $(EXEDIR)/mld_d_pde3d $(EXEDIR)/mld_s_pde3d $(EXEDIR)/mld_d_pde2d $(EXEDIR)/mld_s_pde2d + $(EXEDIR)/amg_d_pde3d $(EXEDIR)/amg_s_pde3d $(EXEDIR)/amg_d_pde2d $(EXEDIR)/amg_s_pde2d verycleanlib: (cd ../..; make veryclean) diff --git a/samples/advanced/pdegen/amg_d_pde2d.f90 b/samples/advanced/pdegen/amg_d_pde2d.f90 index d4e5ad68..c036aa6d 100644 --- a/samples/advanced/pdegen/amg_d_pde2d.f90 +++ b/samples/advanced/pdegen/amg_d_pde2d.f90 @@ -119,7 +119,7 @@ program amg_d_pde2d character(len=10) :: ptype ! preconditioner type integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, - ! AMG cycles for ML + ! AMG cycles for ML ! general AMG data character(len=16) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner @@ -174,6 +174,17 @@ program amg_d_pde2d real(psb_dpk_) :: cthres ! threshold for ILUT factorization integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver + ! Dump data + logical :: dump = .false. + integer(psb_ipk_) :: dlmin ! Minimum level to dump + integer(psb_ipk_) :: dlmax ! Maximum level to dump + logical :: dump_ac = .false. + logical :: dump_rp = .false. + logical :: dump_tprol = .false. + logical :: dump_smoother = .false. + logical :: dump_solver = .false. + logical :: dump_global_num = .false. + end type precdata type(precdata) :: p_choice @@ -338,12 +349,12 @@ program amg_d_pde2d call prec%set('sub_prol', p_choice%prol2, info,pos='post') select case(trim(psb_toupper(p_choice%solve2))) case('INVK') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('INVT') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('AINV') - call prec%set('sub_solve', p_choice%solve, info) - call prec%set('ainv_alg', p_choice%variant, info) + call prec%set('sub_solve', p_choice%solve2, info) + call prec%set('ainv_alg', p_choice%variant2, info) case default call prec%set('sub_solve', p_choice%solve2, info, pos='post') end select @@ -392,6 +403,12 @@ program amg_d_pde2d write(psb_out_unit,'(" ")') end if + if (p_choice%dump) then + call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,& + & ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,& + & smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, & + & global_num=p_choice%dump_global_num) + end if ! ! iterative method parameters ! @@ -530,6 +547,7 @@ contains ! preconditioner type call read_data(prec%descr,inp_unit) ! verbose description of the prec call read_data(prec%ptype,inp_unit) ! preconditioner type + ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps @@ -563,8 +581,9 @@ contains call read_data(prec%aggr_type,inp_unit) ! type of aggregation call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -572,7 +591,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver @@ -580,6 +598,17 @@ contains call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU call read_data(prec%cthres,inp_unit) ! Threshold for ILUT call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver + ! dump + call read_data(prec%dump,inp_unit) ! Dump on file? + call read_data(prec%dlmin,inp_unit) ! Minimum level to dump + call read_data(prec%dlmax,inp_unit) ! Maximum level to dump + call read_data(prec%dump_ac,inp_unit) + call read_data(prec%dump_rp,inp_unit) + call read_data(prec%dump_tprol,inp_unit) + call read_data(prec%dump_smoother,inp_unit) + call read_data(prec%dump_solver,inp_unit) + call read_data(prec%dump_global_num,inp_unit) + if (inp_unit /= psb_inp_unit) then close(inp_unit) end if @@ -626,6 +655,7 @@ contains call psb_bcast(ctxt,prec%mlcycle) call psb_bcast(ctxt,prec%outer_sweeps) call psb_bcast(ctxt,prec%maxlevs) + call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%aggr_prol) call psb_bcast(ctxt,prec%par_aggr_alg) @@ -641,13 +671,23 @@ contains end if call psb_bcast(ctxt,prec%athres) - call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%cmat) call psb_bcast(ctxt,prec%csolve) call psb_bcast(ctxt,prec%csbsolve) call psb_bcast(ctxt,prec%cfill) call psb_bcast(ctxt,prec%cthres) call psb_bcast(ctxt,prec%cjswp) + ! dump + call psb_bcast(ctxt,prec%dump) + call psb_bcast(ctxt,prec%dlmin) + call psb_bcast(ctxt,prec%dlmax) + + call psb_bcast(ctxt,prec%dump_ac) + call psb_bcast(ctxt,prec%dump_rp) + call psb_bcast(ctxt,prec%dump_tprol) + call psb_bcast(ctxt,prec%dump_smoother) + call psb_bcast(ctxt,prec%dump_solver) + call psb_bcast(ctxt,prec%dump_global_num) end subroutine get_parms diff --git a/samples/advanced/pdegen/amg_d_pde3d.f90 b/samples/advanced/pdegen/amg_d_pde3d.f90 index b80e14df..1f6118ca 100644 --- a/samples/advanced/pdegen/amg_d_pde3d.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d.f90 @@ -120,7 +120,7 @@ program amg_d_pde3d character(len=10) :: ptype ! preconditioner type integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, - ! AMG cycles for ML + ! AMG cycles for ML ! general AMG data character(len=16) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner @@ -175,6 +175,17 @@ program amg_d_pde3d real(psb_dpk_) :: cthres ! threshold for ILUT factorization integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver + ! Dump data + logical :: dump = .false. + integer(psb_ipk_) :: dlmin ! Minimum level to dump + integer(psb_ipk_) :: dlmax ! Maximum level to dump + logical :: dump_ac = .false. + logical :: dump_rp = .false. + logical :: dump_tprol = .false. + logical :: dump_smoother = .false. + logical :: dump_solver = .false. + logical :: dump_global_num = .false. + end type precdata type(precdata) :: p_choice @@ -342,12 +353,12 @@ program amg_d_pde3d call prec%set('sub_prol', p_choice%prol2, info,pos='post') select case(trim(psb_toupper(p_choice%solve2))) case('INVK') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('INVT') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('AINV') - call prec%set('sub_solve', p_choice%solve, info) - call prec%set('ainv_alg', p_choice%variant, info) + call prec%set('sub_solve', p_choice%solve2, info) + call prec%set('ainv_alg', p_choice%variant2, info) case default call prec%set('sub_solve', p_choice%solve2, info, pos='post') end select @@ -388,7 +399,7 @@ program amg_d_pde3d call psb_amx(ctxt, thier) call psb_amx(ctxt, tprec) - + if(iam == psb_root_) then write(psb_out_unit,'(" ")') write(psb_out_unit,'("Preconditioner: ",a)') trim(p_choice%descr) @@ -396,6 +407,12 @@ program amg_d_pde3d write(psb_out_unit,'(" ")') end if + if (p_choice%dump) then + call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,& + & ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,& + & smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, & + & global_num=p_choice%dump_global_num) + end if ! ! iterative method parameters ! @@ -534,6 +551,7 @@ contains ! preconditioner type call read_data(prec%descr,inp_unit) ! verbose description of the prec call read_data(prec%ptype,inp_unit) ! preconditioner type + ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps @@ -567,8 +585,9 @@ contains call read_data(prec%aggr_type,inp_unit) ! type of aggregation call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -576,7 +595,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver @@ -584,6 +602,17 @@ contains call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU call read_data(prec%cthres,inp_unit) ! Threshold for ILUT call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver + ! dump + call read_data(prec%dump,inp_unit) ! Dump on file? + call read_data(prec%dlmin,inp_unit) ! Minimum level to dump + call read_data(prec%dlmax,inp_unit) ! Maximum level to dump + call read_data(prec%dump_ac,inp_unit) + call read_data(prec%dump_rp,inp_unit) + call read_data(prec%dump_tprol,inp_unit) + call read_data(prec%dump_smoother,inp_unit) + call read_data(prec%dump_solver,inp_unit) + call read_data(prec%dump_global_num,inp_unit) + if (inp_unit /= psb_inp_unit) then close(inp_unit) end if @@ -630,6 +659,7 @@ contains call psb_bcast(ctxt,prec%mlcycle) call psb_bcast(ctxt,prec%outer_sweeps) call psb_bcast(ctxt,prec%maxlevs) + call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%aggr_prol) call psb_bcast(ctxt,prec%par_aggr_alg) @@ -645,15 +675,26 @@ contains end if call psb_bcast(ctxt,prec%athres) - call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%cmat) call psb_bcast(ctxt,prec%csolve) call psb_bcast(ctxt,prec%csbsolve) call psb_bcast(ctxt,prec%cfill) call psb_bcast(ctxt,prec%cthres) call psb_bcast(ctxt,prec%cjswp) + ! dump + call psb_bcast(ctxt,prec%dump) + call psb_bcast(ctxt,prec%dlmin) + call psb_bcast(ctxt,prec%dlmax) + + call psb_bcast(ctxt,prec%dump_ac) + call psb_bcast(ctxt,prec%dump_rp) + call psb_bcast(ctxt,prec%dump_tprol) + call psb_bcast(ctxt,prec%dump_smoother) + call psb_bcast(ctxt,prec%dump_solver) + call psb_bcast(ctxt,prec%dump_global_num) + end subroutine get_parms end program amg_d_pde3d diff --git a/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 b/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 index 7becb5a1..a6de1d87 100644 --- a/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_d_pde3d_base_mod.f90 @@ -64,7 +64,7 @@ contains b3=done/sqrt(3.0_psb_dpk_) end function b3 function c(x,y,z) - use psb_base_mod, only : psb_dpk_, done + use psb_base_mod, only : psb_dpk_, dzero, done real(psb_dpk_) :: c real(psb_dpk_), intent(in) :: x,y,z c=dzero diff --git a/samples/advanced/pdegen/amg_s_pde2d.f90 b/samples/advanced/pdegen/amg_s_pde2d.f90 index 9211441a..a81d16ff 100644 --- a/samples/advanced/pdegen/amg_s_pde2d.f90 +++ b/samples/advanced/pdegen/amg_s_pde2d.f90 @@ -119,7 +119,7 @@ program amg_s_pde2d character(len=10) :: ptype ! preconditioner type integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, - ! AMG cycles for ML + ! AMG cycles for ML ! general AMG data character(len=16) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner @@ -174,6 +174,17 @@ program amg_s_pde2d real(psb_spk_) :: cthres ! threshold for ILUT factorization integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver + ! Dump data + logical :: dump = .false. + integer(psb_ipk_) :: dlmin ! Minimum level to dump + integer(psb_ipk_) :: dlmax ! Maximum level to dump + logical :: dump_ac = .false. + logical :: dump_rp = .false. + logical :: dump_tprol = .false. + logical :: dump_smoother = .false. + logical :: dump_solver = .false. + logical :: dump_global_num = .false. + end type precdata type(precdata) :: p_choice @@ -338,12 +349,12 @@ program amg_s_pde2d call prec%set('sub_prol', p_choice%prol2, info,pos='post') select case(trim(psb_toupper(p_choice%solve2))) case('INVK') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('INVT') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('AINV') - call prec%set('sub_solve', p_choice%solve, info) - call prec%set('ainv_alg', p_choice%variant, info) + call prec%set('sub_solve', p_choice%solve2, info) + call prec%set('ainv_alg', p_choice%variant2, info) case default call prec%set('sub_solve', p_choice%solve2, info, pos='post') end select @@ -392,6 +403,12 @@ program amg_s_pde2d write(psb_out_unit,'(" ")') end if + if (p_choice%dump) then + call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,& + & ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,& + & smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, & + & global_num=p_choice%dump_global_num) + end if ! ! iterative method parameters ! @@ -530,6 +547,7 @@ contains ! preconditioner type call read_data(prec%descr,inp_unit) ! verbose description of the prec call read_data(prec%ptype,inp_unit) ! preconditioner type + ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps @@ -563,8 +581,9 @@ contains call read_data(prec%aggr_type,inp_unit) ! type of aggregation call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -572,7 +591,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver @@ -580,6 +598,17 @@ contains call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU call read_data(prec%cthres,inp_unit) ! Threshold for ILUT call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver + ! dump + call read_data(prec%dump,inp_unit) ! Dump on file? + call read_data(prec%dlmin,inp_unit) ! Minimum level to dump + call read_data(prec%dlmax,inp_unit) ! Maximum level to dump + call read_data(prec%dump_ac,inp_unit) + call read_data(prec%dump_rp,inp_unit) + call read_data(prec%dump_tprol,inp_unit) + call read_data(prec%dump_smoother,inp_unit) + call read_data(prec%dump_solver,inp_unit) + call read_data(prec%dump_global_num,inp_unit) + if (inp_unit /= psb_inp_unit) then close(inp_unit) end if @@ -626,6 +655,7 @@ contains call psb_bcast(ctxt,prec%mlcycle) call psb_bcast(ctxt,prec%outer_sweeps) call psb_bcast(ctxt,prec%maxlevs) + call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%aggr_prol) call psb_bcast(ctxt,prec%par_aggr_alg) @@ -641,13 +671,23 @@ contains end if call psb_bcast(ctxt,prec%athres) - call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%cmat) call psb_bcast(ctxt,prec%csolve) call psb_bcast(ctxt,prec%csbsolve) call psb_bcast(ctxt,prec%cfill) call psb_bcast(ctxt,prec%cthres) call psb_bcast(ctxt,prec%cjswp) + ! dump + call psb_bcast(ctxt,prec%dump) + call psb_bcast(ctxt,prec%dlmin) + call psb_bcast(ctxt,prec%dlmax) + + call psb_bcast(ctxt,prec%dump_ac) + call psb_bcast(ctxt,prec%dump_rp) + call psb_bcast(ctxt,prec%dump_tprol) + call psb_bcast(ctxt,prec%dump_smoother) + call psb_bcast(ctxt,prec%dump_solver) + call psb_bcast(ctxt,prec%dump_global_num) end subroutine get_parms diff --git a/samples/advanced/pdegen/amg_s_pde3d.f90 b/samples/advanced/pdegen/amg_s_pde3d.f90 index a743b3d6..7542c3a2 100644 --- a/samples/advanced/pdegen/amg_s_pde3d.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d.f90 @@ -120,7 +120,7 @@ program amg_s_pde3d character(len=10) :: ptype ! preconditioner type integer(psb_ipk_) :: outer_sweeps ! number of outer sweeps: sweeps for 1-level, - ! AMG cycles for ML + ! AMG cycles for ML ! general AMG data character(len=16) :: mlcycle ! AMG cycle type integer(psb_ipk_) :: maxlevs ! maximum number of levels in AMG preconditioner @@ -175,6 +175,17 @@ program amg_s_pde3d real(psb_spk_) :: cthres ! threshold for ILUT factorization integer(psb_ipk_) :: cjswp ! sweeps for GS or JAC coarsest-lev subsolver + ! Dump data + logical :: dump = .false. + integer(psb_ipk_) :: dlmin ! Minimum level to dump + integer(psb_ipk_) :: dlmax ! Maximum level to dump + logical :: dump_ac = .false. + logical :: dump_rp = .false. + logical :: dump_tprol = .false. + logical :: dump_smoother = .false. + logical :: dump_solver = .false. + logical :: dump_global_num = .false. + end type precdata type(precdata) :: p_choice @@ -342,12 +353,12 @@ program amg_s_pde3d call prec%set('sub_prol', p_choice%prol2, info,pos='post') select case(trim(psb_toupper(p_choice%solve2))) case('INVK') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('INVT') - call prec%set('sub_solve', p_choice%solve, info) + call prec%set('sub_solve', p_choice%solve2, info) case('AINV') - call prec%set('sub_solve', p_choice%solve, info) - call prec%set('ainv_alg', p_choice%variant, info) + call prec%set('sub_solve', p_choice%solve2, info) + call prec%set('ainv_alg', p_choice%variant2, info) case default call prec%set('sub_solve', p_choice%solve2, info, pos='post') end select @@ -388,7 +399,7 @@ program amg_s_pde3d call psb_amx(ctxt, thier) call psb_amx(ctxt, tprec) - + if(iam == psb_root_) then write(psb_out_unit,'(" ")') write(psb_out_unit,'("Preconditioner: ",a)') trim(p_choice%descr) @@ -396,6 +407,12 @@ program amg_s_pde3d write(psb_out_unit,'(" ")') end if + if (p_choice%dump) then + call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,& + & ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,& + & smoother=p_choice%dump_smoother, solver=p_choice%dump_solver, & + & global_num=p_choice%dump_global_num) + end if ! ! iterative method parameters ! @@ -534,6 +551,7 @@ contains ! preconditioner type call read_data(prec%descr,inp_unit) ! verbose description of the prec call read_data(prec%ptype,inp_unit) ! preconditioner type + ! First smoother / 1-lev preconditioner call read_data(prec%smther,inp_unit) ! smoother type call read_data(prec%jsweeps,inp_unit) ! (pre-)smoother / 1-lev prec sweeps @@ -567,8 +585,9 @@ contains call read_data(prec%aggr_type,inp_unit) ! type of aggregation call read_data(prec%aggr_size,inp_unit) ! Requested size of the aggregates for MATCHBOXP call read_data(prec%aggr_ord,inp_unit) ! ordering for aggregation - call read_data(prec%aggr_filter,inp_unit) ! filtering call read_data(prec%mncrratio,inp_unit) ! minimum aggregation ratio + call read_data(prec%aggr_filter,inp_unit) ! filtering + call read_data(prec%athres,inp_unit) ! smoothed aggr thresh call read_data(prec%thrvsz,inp_unit) ! size of aggr thresh vector if (prec%thrvsz > 0) then call psb_realloc(prec%thrvsz,prec%athresv,info) @@ -576,7 +595,6 @@ contains else read(inp_unit,*) ! dummy read to skip a record end if - call read_data(prec%athres,inp_unit) ! smoothed aggr thresh ! coasest-level solver call read_data(prec%csolve,inp_unit) ! coarsest-lev solver call read_data(prec%csbsolve,inp_unit) ! coarsest-lev subsolver @@ -584,6 +602,17 @@ contains call read_data(prec%cfill,inp_unit) ! fill-in for incompl LU call read_data(prec%cthres,inp_unit) ! Threshold for ILUT call read_data(prec%cjswp,inp_unit) ! sweeps for GS/JAC subsolver + ! dump + call read_data(prec%dump,inp_unit) ! Dump on file? + call read_data(prec%dlmin,inp_unit) ! Minimum level to dump + call read_data(prec%dlmax,inp_unit) ! Maximum level to dump + call read_data(prec%dump_ac,inp_unit) + call read_data(prec%dump_rp,inp_unit) + call read_data(prec%dump_tprol,inp_unit) + call read_data(prec%dump_smoother,inp_unit) + call read_data(prec%dump_solver,inp_unit) + call read_data(prec%dump_global_num,inp_unit) + if (inp_unit /= psb_inp_unit) then close(inp_unit) end if @@ -630,6 +659,7 @@ contains call psb_bcast(ctxt,prec%mlcycle) call psb_bcast(ctxt,prec%outer_sweeps) call psb_bcast(ctxt,prec%maxlevs) + call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%aggr_prol) call psb_bcast(ctxt,prec%par_aggr_alg) @@ -645,15 +675,26 @@ contains end if call psb_bcast(ctxt,prec%athres) - call psb_bcast(ctxt,prec%csizepp) call psb_bcast(ctxt,prec%cmat) call psb_bcast(ctxt,prec%csolve) call psb_bcast(ctxt,prec%csbsolve) call psb_bcast(ctxt,prec%cfill) call psb_bcast(ctxt,prec%cthres) call psb_bcast(ctxt,prec%cjswp) + ! dump + call psb_bcast(ctxt,prec%dump) + call psb_bcast(ctxt,prec%dlmin) + call psb_bcast(ctxt,prec%dlmax) + + call psb_bcast(ctxt,prec%dump_ac) + call psb_bcast(ctxt,prec%dump_rp) + call psb_bcast(ctxt,prec%dump_tprol) + call psb_bcast(ctxt,prec%dump_smoother) + call psb_bcast(ctxt,prec%dump_solver) + call psb_bcast(ctxt,prec%dump_global_num) + end subroutine get_parms end program amg_s_pde3d diff --git a/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 b/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 index 7acac026..ed420eda 100644 --- a/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 +++ b/samples/advanced/pdegen/amg_s_pde3d_base_mod.f90 @@ -64,7 +64,7 @@ contains b3=sone/sqrt(3.0_psb_spk_) end function b3 function c(x,y,z) - use psb_base_mod, only : psb_spk_, sone + use psb_base_mod, only : psb_spk_, szero, sone real(psb_spk_) :: c real(psb_spk_), intent(in) :: x,y,z c=szero diff --git a/samples/advanced/pdegen/runs/amg_pde2d.inp b/samples/advanced/pdegen/runs/amg_pde2d.inp index d3ef6b1d..c3fc58e1 100644 --- a/samples/advanced/pdegen/runs/amg_pde2d.inp +++ b/samples/advanced/pdegen/runs/amg_pde2d.inp @@ -43,11 +43,11 @@ COUPLED ! Parallel aggregation: DEC, SYMDEC, COUPLED MATCHBOXP ! aggregation measure SOC1, MATCHBOXP 8 ! Requested size of the aggregates for MATCHBOXP NATURAL ! Ordering of aggregation NATURAL DEGREE -FILTER ! Filtering of matrix: FILTER NOFILTER -1.5 ! Coarsening ratio, if < 0 use library default +FILTER ! Filtering of matrix: FILTER NOFILTER +-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 -2 ! Number of thresholds in vector, next line ignored if <= 0 0.05 0.025 ! Thresholds --0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 %%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%% BJAC ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC ILU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU @@ -55,3 +55,13 @@ DIST ! Coarsest-level matrix distribution: DIST REPL 1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) 1 ! Number of sweeps for JACOBI/GS/BJAC coarsest-level solver +%%%%%%%%%%% Dump parms %%%%%%%%%%%%%%%%%%%%%%%%%% +F ! Dump preconditioner on file +1 ! Min level +20 ! Max level +T ! Dump AC +T ! Dump RP +F ! Dump TPROL +F ! Dump SMOOTHER +F ! Dump SOLVER +F ! Global numering ? diff --git a/samples/advanced/pdegen/runs/amg_pde3d.inp b/samples/advanced/pdegen/runs/amg_pde3d.inp index 0a600df4..eb254780 100644 --- a/samples/advanced/pdegen/runs/amg_pde3d.inp +++ b/samples/advanced/pdegen/runs/amg_pde3d.inp @@ -41,13 +41,13 @@ VCYCLE ! Type of multilevel CYCLE: VCYCLE WCYCLE KCYCLE MUL SMOOTHED ! Type of aggregation: SMOOTHED UNSMOOTHED COUPLED ! Parallel aggregation: DEC, SYMDEC, COUPLED MATCHBOXP ! aggregation measure SOC1, MATCHBOXP -4 ! Requested size of the aggregates for MATCHBOXP +8 ! Requested size of the aggregates for MATCHBOXP NATURAL ! Ordering of aggregation NATURAL DEGREE -NOFILTER ! Filtering of matrix: FILTER NOFILTER -1.5 ! Coarsening ratio, if < 0 use library default +FILTER ! Filtering of matrix: FILTER NOFILTER +-0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 -2 ! Number of thresholds in vector, next line ignored if <= 0 0.05 0.025 ! Thresholds --0.0100d0 ! Smoothed aggregation threshold, ignored if < 0 %%%%%%%%%%% Coarse level solver %%%%%%%%%%%%%%%% BJAC ! Coarsest-level solver: MUMPS UMF SLU SLUDIST JACOBI GS BJAC ILU ! Coarsest-level subsolver for BJAC: ILU ILUT MILU UMF MUMPS SLU @@ -55,3 +55,13 @@ DIST ! Coarsest-level matrix distribution: DIST REPL 1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) 1 ! Number of sweeps for JACOBI/GS/BJAC coarsest-level solver +%%%%%%%%%%% Dump parms %%%%%%%%%%%%%%%%%%%%%%%%%% +F ! Dump preconditioner on file +1 ! Min level +20 ! Max level +T ! Dump AC +T ! Dump RP +F ! Dump TPROL +F ! Dump SMOOTHER +F ! Dump SOLVER +F ! Global numering ?