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

Merged new serial code.

Browse Source
stopcriterion
Salvatore Filippone 18 years ago
parent 49e78939f6
commit 6d66d1297c
9 changed files with 139 additions and 352 deletions
Show Stats Download Patch File Download Diff File

54
mld_daggrmat_raw_asb.F90
Unescape Escape View File

@ -99,50 +99,26 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
nzt = psb_sp_get_nnzeros(a)
call psb_sp_all(b,nzt,info)
call psb_sp_clip(a,b,info,jmax=nrow)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spall')
call psb_errpush(4010,name,a_err='spclip')
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)
! Out from sp_clip is always in COO, but just in case..
if (tolower(b%fida) /= 'coo') then
call psb_errpush(4010,name,a_err='spclip NOT COO')
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
b%ia1(i) = p%mlia(b%ia1(i))
b%ia2(i) = p%mlia(b%ia2(i))
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
! This is to minimize data exchange
call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_)
if (p%iprcparm(coarse_mat_) == repl_mat_) then
@ -156,9 +132,10 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
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')
call psb_errpush(4010,name,a_err='sp_all')
goto 9999
end if
@ -184,7 +161,7 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='G'
call psb_fixcoo(ac,info)
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999
@ -219,13 +196,14 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(coarse_mat_)
end if
call psb_ipcoo2csr(ac,info)
deallocate(nzbr,idisp)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
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

58
mld_daggrmat_smth_asb.F90
Unescape Escape View File

@ -86,6 +86,8 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am2 => p%av(sm_pr_t_)
am1 => p%av(sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
nglob = psb_cd_get_global_rows(desc_a)
nrow = psb_cd_get_local_rows(desc_a)
@ -116,7 +118,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_halo(p%mlia,desc_a,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='f90_pshalo')
call psb_errpush(4010,name,a_err='psb_halo')
goto 9999
end if
end if
@ -195,11 +197,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
endif
call psb_ipcoo2csr(am4,info)
call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
@ -256,7 +256,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
if (am3%fida=='CSR') then
if (toupper(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
@ -266,7 +266,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
end do
end do
else if (am3%fida=='COO') then
else if (toupper(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)
@ -274,7 +274,13 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am3%aspk(j) = done - omega*am3%aspk(j)
endif
end do
call psb_ipcoo2csr(am3,info)
call psb_spcnv(am3,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv am3')
goto 9999
end if
else
write(0,*) 'Missing implementation of I sum'
call psb_errpush(4010,name)
@ -381,7 +387,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end do
am2%infoa(psb_nnz_) = i
call psb_ipcoo2csr(am2,info)
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv am2')
goto 9999
end if
else
call psb_transp(am1,am2)
endif
@ -433,15 +443,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
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')
call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv b')
goto 9999
end if
@ -522,9 +526,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am1%k=desc_ac%matrix_data(psb_n_col_)
if (np>1) then
call psb_ipcsr2coo(am2,info)
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_ipcsr2coo')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
@ -535,9 +539,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
call psb_ipcoo2csr(am2,info)
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
end if
@ -581,7 +585,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='G'
call psb_fixcoo(ac,info)
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999
call psb_sp_free(b,info)
if(info /= 0) goto 9999
@ -669,9 +673,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='G'
call psb_fixcoo(ac,info)
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_fixcoo')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
call psb_sp_free(b,info)
@ -685,9 +689,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end select
call psb_ipcoo2csr(ac,info)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if

15
mld_dbjac_bld.f90
Unescape Escape View File

@ -333,10 +333,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
case(slu_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_csdp')
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
@ -384,10 +383,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
case(sludist_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_csdp')
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
@ -438,10 +436,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
case(umf_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_csdp')
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if

15
mld_dsp_renum.f90
Unescape Escape View File

@ -62,7 +62,6 @@ subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
!
@ -74,13 +73,7 @@ subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
! (2. GPS band reduction disabled for the time being)
nztota=psb_sp_get_nnzeros(a)
nztotb=psb_sp_get_nnzeros(blck)
call psb_sp_reall(atmp,nztota+nztotb,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_reall')
goto 9999
end if
atmp%fida='COO'
call psb_csdp(a,atmp,info)
call psb_spcnv(a,atmp,info,afmt='coo',dupl=psb_dupl_add_)
call psb_rwextd(a%m+blck%m,atmp,info,blck,rowscale=.false.)
if (p%iprcparm(sub_ren_)==renum_glb_) then
@ -115,7 +108,7 @@ subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
else if (p%iprcparm(sub_ren_)==renum_gps_) then
call psb_ipcoo2csr(atmp,info)
call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
nztmp = psb_sp_get_nnzeros(atmp)
! This is a renumbering with Gibbs-Poole-Stockmeyer
! band reduction. Switched off for now. To be fixed,
@ -171,7 +164,7 @@ subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
enddo
t3 = psb_wtime()
call psb_ipcsr2coo(atmp,info)
call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_)
end if
@ -182,7 +175,7 @@ subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
atmp%ia1(i) = p%perm(a%ia1(i))
atmp%ia2(i) = p%invperm(a%ia2(i))
end do
call psb_fixcoo(atmp,info)
call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_fixcoo')
goto 9999

2
mld_prec_type.f90
Unescape Escape View File

@ -209,7 +209,7 @@ module mld_prec_type
& aggr_names(0:3)=(/'Local aggregation ','Global aggregation',&
& 'New local aggr. ','New global aggr. '/)
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'None ',' ',' ',' ','Halo '/)
& restrict_names(0:4)=(/'None ','Halo ',' ',' ',' '/)
character(len=12), parameter, private :: &
& prolong_names(0:3)=(/'None ','Sum ','Average ','Square root'/)
character(len=15), parameter, private :: &

54
mld_zaggrmat_raw_asb.F90
Unescape Escape View File

@ -100,50 +100,26 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
nzt = psb_sp_get_nnzeros(a)
call psb_sp_all(b,nzt,info)
call psb_sp_clip(a,b,info,jmax=nrow)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spall')
call psb_errpush(4010,name,a_err='spclip')
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)
! Out from sp_clip is always in COO, but just in case..
if (tolower(b%fida) /= 'coo') then
call psb_errpush(4010,name,a_err='spclip NOT COO')
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
b%ia1(i) = p%mlia(b%ia1(i))
b%ia2(i) = p%mlia(b%ia2(i))
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
! This is to minimize data exchange
call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_)
if (p%iprcparm(coarse_mat_) == repl_mat_) then
@ -157,9 +133,10 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
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')
call psb_errpush(4010,name,a_err='sp_all')
goto 9999
end if
@ -185,7 +162,7 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='G'
call psb_fixcoo(ac,info)
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999
@ -220,13 +197,14 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(coarse_mat_)
end if
call psb_ipcoo2csr(ac,info)
deallocate(nzbr,idisp)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
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

58
mld_zaggrmat_smth_asb.F90
Unescape Escape View File

@ -86,6 +86,8 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am2 => p%av(sm_pr_t_)
am1 => p%av(sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
nglob = psb_cd_get_global_rows(desc_a)
nrow = psb_cd_get_local_rows(desc_a)
@ -116,7 +118,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_halo(p%mlia,desc_a,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='f90_pshalo')
call psb_errpush(4010,name,a_err='psb_halo')
goto 9999
end if
end if
@ -195,11 +197,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
endif
call psb_ipcoo2csr(am4,info)
call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
@ -256,7 +256,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
if (am3%fida=='CSR') then
if (toupper(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
@ -266,7 +266,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
end do
end do
else if (am3%fida=='COO') then
else if (toupper(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)
@ -274,7 +274,13 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am3%aspk(j) = zone - omega*am3%aspk(j)
endif
end do
call psb_ipcoo2csr(am3,info)
call psb_spcnv(am3,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv am3')
goto 9999
end if
else
write(0,*) 'Missing implementation of I sum'
call psb_errpush(4010,name)
@ -381,7 +387,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end do
am2%infoa(psb_nnz_) = i
call psb_ipcoo2csr(am2,info)
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv am2')
goto 9999
end if
else
call psb_transp(am1,am2)
endif
@ -433,15 +443,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
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')
call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv b')
goto 9999
end if
@ -522,9 +526,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am1%k=desc_ac%matrix_data(psb_n_col_)
if (np>1) then
call psb_ipcsr2coo(am2,info)
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_ipcsr2coo')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
@ -535,9 +539,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
call psb_ipcoo2csr(am2,info)
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
end if
@ -581,7 +585,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='G'
call psb_fixcoo(ac,info)
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999
call psb_sp_free(b,info)
if(info /= 0) goto 9999
@ -669,9 +673,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='G'
call psb_fixcoo(ac,info)
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_fixcoo')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
call psb_sp_free(b,info)
@ -685,9 +689,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end select
call psb_ipcoo2csr(ac,info)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if

15
mld_zbjac_bld.f90
Unescape Escape View File

@ -334,10 +334,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
case(slu_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_csdp')
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
@ -385,10 +384,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
case(sludist_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_csdp')
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
@ -439,10 +437,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
case(umf_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_csdp')
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if

220
mld_zsp_renum.f90
Unescape Escape View File

@ -64,20 +64,23 @@ subroutine mld_zsp_renum(a,desc_a,blck,p,atmp,info)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
!!!!!!!!!!!!!!!! CHANGE FOR NON-CSR A
!
! CHANGE: Start with a COO atmp. Then change if/when necessary.
! Exit with a COO atmp.
!
! Renumbering type:
! 1. Global column indices
! (2. GPS band reduction disabled for the time being)
nztota=psb_sp_get_nnzeros(a)
nztotb=psb_sp_get_nnzeros(blck)
call psb_spcnv(a,atmp,info,afmt='coo',dupl=psb_dupl_add_)
call psb_rwextd(a%m+blck%m,atmp,info,blck,rowscale=.false.)
if (p%iprcparm(sub_ren_)==renum_glb_) then
atmp%m = a%m + blck%m
atmp%k = a%k
atmp%fida='CSR'
atmp%descra = 'GUN'
! This is the renumbering coherent with global indices..
mglob = psb_cd_get_global_rows(desc_a)
!
! Remember: we have switched IA1=COLS and IA2=ROWS
! Now identify the set of distinct local column indices
@ -103,112 +106,10 @@ subroutine mld_zsp_renum(a,desc_a,blck,p,atmp,info)
enddo
t3 = psb_wtime()
! Build ATMP with new numbering.
nztmp=size(atmp%aspk)
allocate(itmp(max(8,atmp%m+2,nztmp+2)),ztmp(atmp%m),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
j = 1
atmp%ia2(1) = 1
do i=1, atmp%m
ir = p%perm(i)
if (ir <= a%m ) then
nzl = a%ia2(ir+1) - a%ia2(ir)
if (nzl > size(ztmp)) then
call psb_realloc(nzl,ztmp,info)
if(info/=0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
jj = a%ia2(ir)
k=0
do kk=1, nzl
if (a%ia1(jj+kk-1)<=atmp%m) then
k = k + 1
ztmp(k) = a%aspk(jj+kk-1)
atmp%ia1(j+k-1) = p%invperm(a%ia1(jj+kk-1))
endif
enddo
call psb_msort(atmp%ia1(j:j+k-1),ix=itmp2)
do kk=1,k
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
enddo
else if (ir <= atmp%m ) then
ir = ir - a%m
nzl = blck%ia2(ir+1) - blck%ia2(ir)
if (nzl > size(ztmp)) then
call psb_realloc(nzl,ztmp,info)
if(info/=0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
jj = blck%ia2(ir)
k=0
do kk=1, nzl
if (blck%ia1(jj+kk-1)<=atmp%m) then
k = k + 1
ztmp(k) = blck%aspk(jj+kk-1)
atmp%ia1(j+k-1) = p%invperm(blck%ia1(jj+kk-1))
endif
enddo
call psb_msort(atmp%ia1(j:j+k-1),ix=itmp2)
do kk=1,k
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
enddo
else
write(0,*) 'Row index error 1 :',i,ir
endif
j = j + k
atmp%ia2(i+1) = j
enddo
t4 = psb_wtime()
deallocate(itmp,itmp2,ztmp)
else if (p%iprcparm(sub_ren_)==renum_gps_) then
atmp%m = a%m + blck%m
atmp%k = a%k
atmp%fida='CSR'
atmp%descra = 'GUN'
do i=1, a%m
atmp%ia2(i) = a%ia2(i)
do j= a%ia2(i), a%ia2(i+1)-1
atmp%ia1(j) = a%ia1(j)
enddo
enddo
atmp%ia2(a%m+1) = a%ia2(a%m+1)
nztota = atmp%ia2(a%m+1) -1
if (blck%m>0) then
do i=1, blck%m
atmp%ia2(a%m+i) = nztota+blck%ia2(i)
do j= blck%ia2(i), blck%ia2(i+1)-1
atmp%ia1(nztota+j) = blck%ia1(j)
enddo
enddo
atmp%ia2(atmp%m+1) = nztota+blck%ia2(blck%m+1)
endif
nztmp = atmp%ia2(atmp%m+1) - 1
call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
nztmp = psb_sp_get_nnzeros(atmp)
! This is a renumbering with Gibbs-Poole-Stockmeyer
! band reduction. Switched off for now. To be fixed,
! gps_reduction should get p%perm.
@ -258,95 +159,30 @@ subroutine mld_zsp_renum(a,desc_a,blck,p,atmp,info)
enddo
do k=1, nnr
p%invperm(p%perm(k)) = k
enddo
t3 = psb_wtime()
! Build ATMP with new numbering.
allocate(itmp2(max(8,atmp%m+2,nztmp+2)),ztmp(atmp%m),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
j = 1
atmp%ia2(1) = 1
do i=1, atmp%m
ir = p%perm(i)
if (ir <= a%m ) then
nzl = a%ia2(ir+1) - a%ia2(ir)
if (nzl > size(ztmp)) then
call psb_realloc(nzl,ztmp,info)
if(info/=0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
jj = a%ia2(ir)
k=0
do kk=1, nzl
if (a%ia1(jj+kk-1)<=atmp%m) then
k = k + 1
ztmp(k) = a%aspk(jj+kk-1)
atmp%ia1(j+k-1) = p%invperm(a%ia1(jj+kk-1))
endif
enddo
call psb_msort(atmp%ia1(j:j+k-1),ix=itmp2)
do kk=1,k
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
enddo
else if (ir <= atmp%m ) then
ir = ir - a%m
nzl = blck%ia2(ir+1) - blck%ia2(ir)
if (nzl > size(ztmp)) then
call psb_realloc(nzl,ztmp,info)
if(info/=0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
jj = blck%ia2(ir)
k=0
do kk=1, nzl
if (blck%ia1(jj+kk-1)<=atmp%m) then
k = k + 1
ztmp(k) = blck%aspk(jj+kk-1)
atmp%ia1(j+k-1) = p%invperm(blck%ia1(jj+kk-1))
endif
enddo
call psb_msort(atmp%ia1(j:j+k-1),ix=itmp2)
do kk=1,k
atmp%aspk(j+kk-1) = ztmp(itmp2(kk))
enddo
else
write(0,*) 'Row index error 1 :',i,ir
endif
j = j + k
atmp%ia2(i+1) = j
enddo
t4 = psb_wtime()
deallocate(itmp,itmp2,ztmp)
call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_)
end if
! Rebuild ATMP with new numbering.
nztmp=psb_sp_get_nnzeros(atmp)
do i=1,nztmp
atmp%ia1(i) = p%perm(a%ia1(i))
atmp%ia2(i) = p%invperm(a%ia2(i))
end do
call psb_spcnv(atmp,info,afmt='coo',dupl=psb_dupl_add_)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_fixcoo')
goto 9999
end if
t4 = psb_wtime()
call psb_erractionrestore(err_act)
return

Write Preview
Loading…
Cancel
Save