!!$ !!$ !!$ MD2P4 !!$ Multilevel Domain Decomposition Parallel Preconditioner Package for PSBLAS !!$ for !!$ Parallel Sparse BLAS v2.0 !!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata !!$ Alfredo Buttari University of Rome Tor Vergata !!$ Daniela di Serafino Second University of Naples !!$ Pasqua D'Ambra ICAR-CNR !!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: !!$ 1. Redistributions of source code must retain the above copyright !!$ notice, this list of conditions and the following disclaimer. !!$ 2. Redistributions in binary form must reproduce the above copyright !!$ notice, this list of conditions, and the following disclaimer in the !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the MD2P4 group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR !!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MD2P4 GROUP OR ITS CONTRIBUTORS !!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR !!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF !!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS !!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info) use psb_base_mod use psb_prec_mod, mld_protect_name => mld_daggrmat_asb implicit none type(psb_dspmat_type), intent(in), target :: a type(psb_dbaseprc_type), intent(inout), target :: p type(psb_dspmat_type), intent(inout), target :: ac type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(inout) :: desc_ac integer, intent(out) :: info logical, parameter :: aggr_dump=.false. integer ::ictxt,np,me, err_act, icomm character(len=20) :: name, ch_err name='mld_daggrmat_asb' if(psb_get_errstatus().ne.0) return info=0 call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_a) icomm = psb_cd_get_mpic(desc_a) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) select case (p%iprcparm(smth_kind_)) case (no_smth_) call raw_aggregate(info) if(info /= 0) then call psb_errpush(4010,name,a_err='raw_aggregate') goto 9999 end if if (aggr_dump) call psb_csprt(90+me,ac,head='% Raw aggregate.') case(smth_omg_,smth_biz_) if (aggr_dump) call psb_csprt(70+me,a,head='% Input matrix') call smooth_aggregate(info) if(info /= 0) then call psb_errpush(4010,name,a_err='smooth_aggregate') goto 9999 end if if (aggr_dump) call psb_csprt(90+me,ac,head='% Smooth aggregate.') case default call psb_errpush(4010,name,a_err=name) goto 9999 end select call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then call psb_error() return end if return contains subroutine raw_aggregate(info) use psb_base_mod use psb_prec_type #ifdef MPI_MOD use mpi #endif implicit none #ifdef MPI_H include 'mpif.h' #endif integer, intent(out) :: info type(psb_dspmat_type) :: b integer, pointer :: nzbr(:), idisp(:) integer :: ictxt, nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, np, me, nzt,jl,nzl,nlr,& & icomm,naggrm1, i, j, k, err_act name='raw_aggregate' if(psb_get_errstatus().ne.0) return info=0 call psb_erractionsave(err_act) call psb_nullify_sp(b) ictxt = psb_cd_get_context(desc_a) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt, me, np) nglob = psb_cd_get_global_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) naggr = p%nlaggr(me+1) ntaggr = sum(p%nlaggr) allocate(nzbr(np), idisp(np),stat=info) if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& & a_err='integer') goto 9999 end if naggrm1=sum(p%nlaggr(1:me)) if (p%iprcparm(coarse_mat_) == mat_repl_) then do i=1, nrow p%mlia(i) = p%mlia(i) + naggrm1 end do call psb_halo(p%mlia,desc_a,info) end if if(info /= 0) then call psb_errpush(4010,name,a_err='psb_halo') goto 9999 end if nzt = psb_sp_get_nnzeros(a) call psb_sp_all(b,nzt,info) if(info /= 0) then call psb_errpush(4010,name,a_err='spall') goto 9999 end if call psb_sp_setifld(psb_dupl_ovwrt_,psb_dupl_,b,info) call psb_sp_setifld(psb_upd_dflt_,psb_upd_,b,info) b%fida = 'COO' b%m=a%m b%k=a%k call psb_csdp(a,b,info) if(info /= 0) then info=4010 ch_err='psb_csdp' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if nzt = psb_sp_get_nnzeros(b) j = 0 do i=1, nzt if ((1<=b%ia2(i)).and.(b%ia2(i)<=nrow)) then j = j + 1 b%aspk(j) = b%aspk(i) b%ia1(j) = p%mlia(b%ia1(i)) b%ia2(j) = p%mlia(b%ia2(i)) end if enddo b%infoa(psb_nnz_)=j call psb_fixcoo(b,info) nzt = psb_sp_get_nnzeros(b) call psb_sp_reall(b,nzt,info) if(info /= 0) then call psb_errpush(4010,name,a_err='spreall') goto 9999 end if b%m = naggr b%k = naggr if (p%iprcparm(coarse_mat_) == mat_repl_) then call psb_cdrep(ntaggr,ictxt,desc_ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdrep') goto 9999 end if nzbr(:) = 0 nzbr(me+1) = nzt call psb_sum(ictxt,nzbr(1:np)) nzac = sum(nzbr) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='spall') goto 9999 end if do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,& & mpi_double_precision,icomm,info) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& & mpi_integer,icomm,info) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& & mpi_integer,icomm,info) if(info /= 0) then info=-1 call psb_errpush(info,name) goto 9999 end if ac%m = ntaggr ac%k = ntaggr ac%infoa(psb_nnz_) = nzac ac%fida='COO' ac%descra='G' call psb_fixcoo(ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='sp_free') goto 9999 end if else if (p%iprcparm(coarse_mat_) == mat_distr_) then call psb_cdall(ictxt,desc_ac,info,nl=naggr) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdall') goto 9999 end if call psb_cdasb(desc_ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdasb') goto 9999 end if call psb_sp_clone(b,ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='spclone') goto 9999 end if call psb_sp_free(b,info) if(info /= 0) then call psb_errpush(4010,name,a_err='sp_free') goto 9999 end if else write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(coarse_mat_) end if call psb_ipcoo2csr(ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='ipcoo2csr') goto 9999 end if deallocate(nzbr,idisp) call psb_erractionrestore(err_act) return 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then call psb_error() return end if return end subroutine raw_aggregate subroutine smooth_aggregate(info) use psb_base_mod use psb_prec_type #ifdef MPI_MOD use mpi #endif implicit none #ifdef MPI_H include 'mpif.h' #endif integer, intent(out) :: info type(psb_dspmat_type) :: b integer, pointer :: nzbr(:), idisp(:) integer :: ictxt, nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, np, me, & & icomm, naggrm1,naggrp1,i,j,err_act,k,nzl type(psb_dspmat_type), pointer :: am1,am2 type(psb_dspmat_type) :: am3,am4 logical :: ml_global_nmb logical, parameter :: test_dump=.false.,debug=.false. integer, parameter :: ncmax=16 real(kind(1.d0)) :: omega, anorm, tmp, dg character(len=20) :: name name='smooth_aggregate' if(psb_get_errstatus().ne.0) return info=0 call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_a) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt, me, np) call psb_nullify_sp(b) call psb_nullify_sp(am3) call psb_nullify_sp(am4) am2 => p%av(sm_pr_t_) am1 => p%av(sm_pr_) nglob = psb_cd_get_global_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) naggr = p%nlaggr(me+1) ntaggr = sum(p%nlaggr) allocate(nzbr(np), idisp(np),stat=info) if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& & a_err='integer') goto 9999 end if naggrm1 = sum(p%nlaggr(1:me)) naggrp1 = sum(p%nlaggr(1:me+1)) ml_global_nmb = ( (p%iprcparm(smth_kind_) == smth_omg_).or.& & ( (p%iprcparm(smth_kind_) == smth_biz_).and.& & (p%iprcparm(coarse_mat_) == mat_repl_)) ) if (ml_global_nmb) then p%mlia(1:nrow) = p%mlia(1:nrow) + naggrm1 call psb_halo(p%mlia,desc_a,info) if(info /= 0) then call psb_errpush(4010,name,a_err='f90_pshalo') goto 9999 end if end if if (aggr_dump) then open(30+me) write(30+me,*) '% Aggregation map' do i=1,ncol write(30+me,*) i,p%mlia(i) end do close(30+me) end if ! naggr: number of local aggregates ! nrow: local rows. ! allocate(p%dorig(nrow),stat=info) if (info /= 0) then info=4025 call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),& & a_err='real(kind(1.d0))') goto 9999 end if ! Get diagonal D call psb_sp_getdiag(a,p%dorig,info) if(info /= 0) then call psb_errpush(4010,name,a_err='sp_getdiag') goto 9999 end if do i=1,size(p%dorig) if (p%dorig(i) /= dzero) then p%dorig(i) = done / p%dorig(i) else p%dorig(i) = done end if end do ! where (p%dorig /= dzero) ! p%dorig = done / p%dorig ! elsewhere ! p%dorig = done ! end where ! 1. Allocate Ptilde in sparse matrix form am4%fida='COO' am4%m=ncol if (ml_global_nmb) then am4%k=ntaggr call psb_sp_all(ncol,ntaggr,am4,ncol,info) else am4%k=naggr call psb_sp_all(ncol,naggr,am4,ncol,info) endif if(info /= 0) then call psb_errpush(4010,name,a_err='spall') goto 9999 end if if (ml_global_nmb) then do i=1,ncol am4%aspk(i) = done am4%ia1(i) = i am4%ia2(i) = p%mlia(i) end do am4%infoa(psb_nnz_) = ncol else do i=1,nrow am4%aspk(i) = done am4%ia1(i) = i am4%ia2(i) = p%mlia(i) end do am4%infoa(psb_nnz_) = nrow endif call psb_ipcoo2csr(am4,info) if(info /= 0) then call psb_errpush(4010,name,a_err='ipcoo2csr') goto 9999 end if call psb_sp_clone(a,am3,info) if(info /= 0) then call psb_errpush(4010,name,a_err='spclone') goto 9999 end if ! ! WARNING: the cycles below assume that AM3 does have ! its diagonal elements stored explicitly!!! ! Should we switch to something safer? ! call psb_sp_scal(am3,p%dorig,info) if(info /= 0) goto 9999 if (p%iprcparm(om_choice_) == lib_choice_) then if (p%iprcparm(smth_kind_) == smth_biz_) then ! ! This only works with CSR. ! anorm = dzero dg = done do i=1,am3%m tmp = dzero do j=am3%ia2(i),am3%ia2(i+1)-1 if (am3%ia1(j) <= am3%m) then tmp = tmp + dabs(am3%aspk(j)) endif if (am3%ia1(j) == i ) then dg = dabs(am3%aspk(j)) end if end do anorm = max(anorm,tmp/dg) enddo call psb_amx(ictxt,anorm) else anorm = psb_spnrmi(am3,desc_a,info) endif omega = 4.d0/(3.d0*anorm) p%dprcparm(smooth_omega_) = omega else if (p%iprcparm(om_choice_) == user_choice_) then omega = p%dprcparm(smooth_omega_) else if (p%iprcparm(om_choice_) /= user_choice_) then write(0,*) me,'Error: invalid choice for OMEGA in blaggrmat?? ',& & p%iprcparm(om_choice_) end if if (am3%fida=='CSR') then do i=1,am3%m do j=am3%ia2(i),am3%ia2(i+1)-1 if (am3%ia1(j) == i) then am3%aspk(j) = done - omega*am3%aspk(j) else am3%aspk(j) = - omega*am3%aspk(j) end if end do end do else if (am3%fida=='COO') then do j=1,am3%infoa(psb_nnz_) if (am3%ia1(j) /= am3%ia2(j)) then am3%aspk(j) = - omega*am3%aspk(j) else am3%aspk(j) = done - omega*am3%aspk(j) endif end do call psb_ipcoo2csr(am3,info) else write(0,*) 'Missing implementation of I sum' call psb_errpush(4010,name) goto 9999 end if if (test_dump) then open(30+me) write(30+me,*) 'OMEGA: ',omega do i=1,size(p%dorig) write(30+me,*) p%dorig(i) end do close(30+me) end if if (test_dump) call & & psb_csprt(20+me,am4,head='% Operator Ptilde.',ivr=desc_a%loc_to_glob) if (test_dump) call psb_csprt(40+me,am3,head='% (I-wDA)',ivr=desc_a%loc_to_glob,& & ivc=desc_a%loc_to_glob) if (debug) write(0,*) me,'Done gather, going for SYMBMM 1' ! ! Symbmm90 does the allocation for its result. ! ! am1 = (i-wDA)Ptilde ! Doing it this way means to consider diag(Ai) ! ! call psb_symbmm(am3,am4,am1,info) if(info /= 0) then call psb_errpush(4010,name,a_err='symbmm 1') goto 9999 end if call psb_numbmm(am3,am4,am1) if (debug) write(0,*) me,'Done NUMBMM 1' call psb_sp_free(am4,info) if(info /= 0) then call psb_errpush(4010,name,a_err='sp_free') goto 9999 end if if (ml_global_nmb) then ! ! Now we have to gather the halo of am1, and add it to itself ! to multiply it by A, ! call psb_sphalo(am1,desc_a,am4,info,clcnv=.false.) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sphalo') goto 9999 end if call psb_rwextd(ncol,am1,info,b=am4) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_rwextd') goto 9999 end if call psb_sp_free(am4,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if else call psb_rwextd(ncol,am1,info) if(info /= 0) then call psb_errpush(4010,name,a_err='rwextd') goto 9999 end if endif if (test_dump) & & call psb_csprt(60+me,am1,head='% (I-wDA)Pt',ivr=desc_a%loc_to_glob) call psb_symbmm(a,am1,am3,info) if(info /= 0) then call psb_errpush(4010,name,a_err='symbmm 2') goto 9999 end if call psb_numbmm(a,am1,am3) if (debug) write(0,*) me,'Done NUMBMM 2' if (p%iprcparm(smth_kind_) == smth_omg_) then call psb_transp(am1,am2,fmt='COO') nzl = am2%infoa(psb_nnz_) i=0 ! ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in p%mlia(:) ! do k=1, nzl if ((naggrm1 < am2%ia1(k)) .and.(am2%ia1(k) <= naggrp1)) then i = i+1 am2%aspk(i) = am2%aspk(k) am2%ia1(i) = am2%ia1(k) am2%ia2(i) = am2%ia2(k) end if end do am2%infoa(psb_nnz_) = i call psb_ipcoo2csr(am2,info) else call psb_transp(am1,am2) endif if (debug) write(0,*) me,'starting sphalo/ rwxtd' if (p%iprcparm(smth_kind_) == smth_omg_) then ! am2 = ((i-wDA)Ptilde)^T call psb_sphalo(am3,desc_a,am4,info,clcnv=.false.) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sphalo') goto 9999 end if call psb_rwextd(ncol,am3,info,b=am4) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_rwextd') goto 9999 end if call psb_sp_free(am4,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if else if (p%iprcparm(smth_kind_) == smth_biz_) then call psb_rwextd(ncol,am3,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_rwextd') goto 9999 end if endif if (debug) write(0,*) me,'starting symbmm 3' call psb_symbmm(am2,am3,b,info) if(info /= 0) then call psb_errpush(4010,name,a_err='symbmm 3') goto 9999 end if if (debug) write(0,*) me,'starting numbmm 3' call psb_numbmm(am2,am3,b) if (debug) write(0,*) me,'Done NUMBMM 3' !!$ if (aggr_dump) call csprt(50+me,am1,head='% Operator PTrans.') call psb_sp_free(am3,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if call psb_ipcsr2coo(b,info) if(info /= 0) then call psb_errpush(4010,name,a_err='ipcsr2coo') goto 9999 end if call psb_fixcoo(b,info) if(info /= 0) then call psb_errpush(4010,name,a_err='fixcoo') goto 9999 end if if (test_dump) call psb_csprt(80+me,b,head='% Smoothed aggregate AC.') select case(p%iprcparm(smth_kind_)) case(smth_omg_) select case(p%iprcparm(coarse_mat_)) case(mat_distr_) call psb_sp_clone(b,ac,info) if(info /= 0) goto 9999 nzac = ac%infoa(psb_nnz_) nzl = ac%infoa(psb_nnz_) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1)) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdall') goto 9999 end if call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdins') goto 9999 end if if (debug) write(0,*) me,'Created aux descr. distr.' call psb_cdasb(desc_ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdasb') goto 9999 end if if (debug) write(0,*) me,'Asmbld aux descr. distr.' call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I') if(info /= 0) then call psb_errpush(4010,name,a_err='psglob_to_loc') goto 9999 end if call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I') if(info /= 0) then call psb_errpush(4010,name,a_err='psglob_to_loc') goto 9999 end if ac%m=desc_ac%matrix_data(psb_n_row_) ac%k=desc_ac%matrix_data(psb_n_col_) ac%fida='COO' ac%descra='G' call psb_sp_free(b,info) if (info == 0) deallocate(nzbr,idisp,stat=info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if if (np>1) then nzl = psb_sp_get_nnzeros(am1) call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I') if(info /= 0) then call psb_errpush(4010,name,a_err='psb_glob_to_loc') goto 9999 end if endif am1%k=desc_ac%matrix_data(psb_n_col_) if (np>1) then call psb_ipcsr2coo(am2,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_ipcsr2coo') goto 9999 end if nzl = am2%infoa(psb_nnz_) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I') if(info /= 0) then call psb_errpush(4010,name,a_err='psb_glob_to_loc') goto 9999 end if call psb_ipcoo2csr(am2,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_ipcoo2csr') goto 9999 end if end if am2%m=desc_ac%matrix_data(psb_n_col_) if (debug) write(0,*) me,'Done ac ' case(mat_repl_) ! ! call psb_cdrep(ntaggr,ictxt,desc_ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdrep') goto 9999 end if nzbr(:) = 0 nzbr(me+1) = b%infoa(psb_nnz_) call psb_sum(ictxt,nzbr(1:np)) nzac = sum(nzbr) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) if(info /= 0) goto 9999 do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,& & mpi_double_precision,icomm,info) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& & mpi_integer,icomm,info) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& & mpi_integer,icomm,info) if(info /= 0) goto 9999 ac%m = ntaggr ac%k = ntaggr ac%infoa(psb_nnz_) = nzac ac%fida='COO' ac%descra='G' call psb_fixcoo(ac,info) if(info /= 0) goto 9999 call psb_sp_free(b,info) if(info /= 0) goto 9999 if (me==0) then if (test_dump) call psb_csprt(80+me,ac,head='% Smoothed aggregate AC.') endif deallocate(nzbr,idisp) case default write(0,*) 'Inconsistent input in smooth_new_aggregate' end select case(smth_biz_) select case(p%iprcparm(coarse_mat_)) case(mat_distr_) call psb_sp_clone(b,ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='spclone') goto 9999 end if call psb_cdall(ictxt,desc_ac,info,nl=naggr) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdall') goto 9999 end if call psb_cdasb(desc_ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdasb') goto 9999 end if call psb_sp_free(b,info) if(info /= 0) then call psb_errpush(4010,name,a_err='sp_free') goto 9999 end if case(mat_repl_) ! ! call psb_cdrep(ntaggr,ictxt,desc_ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_cdrep') goto 9999 end if nzbr(:) = 0 nzbr(me+1) = b%infoa(psb_nnz_) call psb_sum(ictxt,nzbr(1:np)) nzac = sum(nzbr) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sp_all') goto 9999 end if do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,& & mpi_double_precision,icomm,info) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& & mpi_integer,icomm,info) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& & mpi_integer,icomm,info) if(info /= 0) then info=-1 call psb_errpush(info,name) goto 9999 end if ac%m = ntaggr ac%k = ntaggr ac%infoa(psb_nnz_) = nzac ac%fida='COO' ac%descra='G' call psb_fixcoo(ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_fixcoo') goto 9999 end if call psb_sp_free(b,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_sp_free') goto 9999 end if end select deallocate(nzbr,idisp) end select call psb_ipcoo2csr(ac,info) if(info /= 0) then call psb_errpush(4010,name,a_err='psb_ipcoo2csr') goto 9999 end if if (debug) write(0,*) me,'Done smooth_aggregate ' call psb_erractionrestore(err_act) return 9999 continue call psb_errpush(info,name) call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then call psb_error() return end if return end subroutine smooth_aggregate end subroutine mld_daggrmat_asb