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

took out problem that causes bug and other func calls that arent needed for this current test

Browse Source
scr-persistent-collective
Soren Rasmussen 6 years ago
parent 84c52822f0
commit 47325ab9ee
1 changed files with 96 additions and 84 deletions
Show Stats Download Patch File Download Diff File

180
test/fileread/psb_halo_df_test.f90
Unescape Escape View File

@ -29,6 +29,8 @@
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
program psb_df_sample program psb_df_sample
use psb_base_mod use psb_base_mod
use psb_prec_mod use psb_prec_mod
@ -74,13 +76,14 @@ program psb_df_sample
integer(psb_ipk_) :: internal, m,ii,nnzero integer(psb_ipk_) :: internal, m,ii,nnzero
real(psb_dpk_) :: t1, t2, tprec real(psb_dpk_) :: t1, t2, tprec
real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp
integer(psb_ipk_) :: nrhs, nrow, n_row, dim, ne, nv integer(psb_ipk_) :: nrhs, nrow, n_row, dim, ne, nv, ncol
integer(psb_ipk_), allocatable :: ivg(:), perm(:) integer(psb_ipk_), allocatable :: ivg(:), perm(:)
integer(psb_ipk_), allocatable :: ipv(:) integer(psb_ipk_), allocatable :: ipv(:)
character(len=40) :: fname, fnout character(len=40) :: fname, fnout
! persistant communication ! persistant communication
integer(psb_ipk_), allocatable :: iv(:), xa(:) integer(psb_lpk_), allocatable :: iv(:)
real(psb_dpk_), allocatable :: xa(:)
call psb_init(ictxt) call psb_init(ictxt)
call psb_info(ictxt,iam,np) call psb_info(ictxt,iam,np)
@ -176,6 +179,11 @@ program psb_df_sample
case('BLOCK') case('BLOCK')
if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")')
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block)
print *, "---ARTLESS: after psb_matdist1"
! call desc_a%cd_get_list
! call desc_a%cd_v_get_list
! print *, "desc_a%v_halo_index", desc_a%v_get_list()
case('GRAPH') case('GRAPH')
if (iam == psb_root_) then if (iam == psb_root_) then
@ -193,26 +201,29 @@ program psb_df_sample
case default case default
if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")')
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block)
end select
end select
call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_) ! call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_)
call psb_geall(x_col,desc_a,info) call psb_geall(x_col,desc_a,info)
call x_col%zero() ! change to mpi rank? Artless call x_col%zero() ! change to mpi rank? Artless
! !
nrow=desc_a%get_local_rows() nrow=desc_a%get_local_rows()
ncol=desc_a%get_local_cols() ncol=desc_a%get_local_cols()
iv = [ (i,i=1,ncol)] iv = [ (i,i=1,ncol)]
call loc_to_glob(iv,desc_a,info) ! call desc_a%loc_to_glob(iv,info) ! call psb_loc_to_glob(iv,desc_a,info) !
call desc_a%l2gv1(iv,info)
! call desc_a%locgv1(iv,info)
xa(1:nrow) = iv(1:nrow) xa = iv ! error
xa(nrow+1:ncol) = 0.0 xa(nrow+1:ncol) = 0.0
call x_col%set(xa) call x_col%set_vect(xa)
call psb_halo(x_col,desc_a,info) call psb_halo(x_col,desc_a,info)
ha = x_col%get_vect() ! ha = x_col%get_vect() xa = x_col%get_vect() ! ha = x_col%get_vect()
do i=nrow+1,ncol do i=nrow+1,ncol
if (ha(i) /= iv(i)) then if (xa(i) /= iv(i)) then ! ha
write(0,*) 'Mismatch ',i,ha(i),iv(i) write(0,*) 'Mismatch ',i,xa(i),iv(i) ! ha
end if end if
end do end do
@ -235,92 +246,93 @@ program psb_df_sample
! !
call prec%init(ictxt,ptype,info) ! call prec%init(ictxt,ptype,info)
! building the preconditioner ! building the preconditioner
t1 = psb_wtime() t1 = psb_wtime()
call prec%build(a,desc_a,info) ! call prec%build(a,desc_a,info)
tprec = psb_wtime()-t1 ! tprec = psb_wtime()-t1
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld')
goto 9999 goto 9999
end if end if
call psb_amx(ictxt,tprec) ! call psb_amx(ictxt,tprec)
if(iam == psb_root_) then ! if(iam == psb_root_) then
write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec ! write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec
write(psb_out_unit,'(" ")') ! write(psb_out_unit,'(" ")')
end if ! end if
cond = dzero ! cond = dzero
iparm = 0 ! iparm = 0
call psb_barrier(ictxt) ! call psb_barrier(ictxt)
t1 = psb_wtime() ! t1 = psb_wtime()
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& ! call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,& ! & itmax=itmax,iter=iter,err=err,itrace=itrace,&
& istop=istopc,irst=irst,cond=cond) ! & istop=istopc,irst=irst,cond=cond)
call psb_barrier(ictxt) ! call psb_barrier(ictxt)
t2 = psb_wtime() - t1 ! t2 = psb_wtime() - t1
call psb_amx(ictxt,t2) ! call psb_amx(ictxt,t2)
call psb_geaxpby(done,b_col,dzero,r_col,desc_a,info) ! call psb_geaxpby(done,b_col,dzero,r_col,desc_a,info)
call psb_spmm(-done,a,x_col,done,r_col,desc_a,info) ! call psb_spmm(-done,a,x_col,done,r_col,desc_a,info)
resmx = psb_genrm2(r_col,desc_a,info) ! resmx = psb_genrm2(r_col,desc_a,info)
resmxp = psb_geamax(r_col,desc_a,info) ! resmxp = psb_geamax(r_col,desc_a,info)
amatsize = a%sizeof() ! amatsize = a%sizeof()
descsize = desc_a%sizeof() ! descsize = desc_a%sizeof()
precsize = prec%sizeof() ! precsize = prec%sizeof()
call psb_sum(ictxt,amatsize) ! call psb_sum(ictxt,amatsize)
call psb_sum(ictxt,descsize) ! call psb_sum(ictxt,descsize)
call psb_sum(ictxt,precsize) ! call psb_sum(ictxt,precsize)
if (iam == psb_root_) then
call prec%descr() ! if (iam == psb_root_) then
write(psb_out_unit,'("Matrix: ",a)')mtrx_file ! call prec%descr()
write(psb_out_unit,'("Computed solution on ",i8," processors")')np ! write(psb_out_unit,'("Matrix: ",a)')mtrx_file
write(psb_out_unit,'("Iterations to convergence: ",i6)')iter ! write(psb_out_unit,'("Computed solution on ",i8," processors")')np
write(psb_out_unit,'("Error estimate on exit : ",es12.5)') err ! write(psb_out_unit,'("Iterations to convergence: ",i6)')iter
write(psb_out_unit,'("Time to buil prec. : ",es12.5)')tprec ! write(psb_out_unit,'("Error estimate on exit : ",es12.5)') err
write(psb_out_unit,'("Time to solve system : ",es12.5)')t2 ! write(psb_out_unit,'("Time to buil prec. : ",es12.5)')tprec
write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/(iter) ! write(psb_out_unit,'("Time to solve system : ",es12.5)')t2
write(psb_out_unit,'("Total time : ",es12.5)')t2+tprec ! write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/(iter)
write(psb_out_unit,'("Residual norm 2 : ",es12.5)')resmx ! write(psb_out_unit,'("Total time : ",es12.5)')t2+tprec
write(psb_out_unit,'("Residual norm inf : ",es12.5)')resmxp ! write(psb_out_unit,'("Residual norm 2 : ",es12.5)')resmx
write(psb_out_unit,'("Condition number : ",es12.5)')cond ! write(psb_out_unit,'("Residual norm inf : ",es12.5)')resmxp
write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize ! write(psb_out_unit,'("Condition number : ",es12.5)')cond
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize ! write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize
write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize ! write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize
write(psb_out_unit,'("Storage format for A : ",a)')& ! write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize
& a%get_fmt() ! write(psb_out_unit,'("Storage format for A : ",a)')&
write(psb_out_unit,'("Storage format for DESC_A : ",a)')& ! & a%get_fmt()
& desc_a%get_fmt() ! write(psb_out_unit,'("Storage format for DESC_A : ",a)')&
end if ! & desc_a%get_fmt()
! end if
call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_)
if (info == psb_success_) & ! call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_)
& call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) ! if (info == psb_success_) &
if (info /= psb_success_) goto 9999 ! & call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_)
if (iam == psb_root_) then ! if (info /= psb_success_) goto 9999
write(psb_err_unit,'(" ")')
write(psb_err_unit,'("Saving x on file")') ! if (iam == psb_root_) then
write(20,*) 'matrix: ',mtrx_file ! write(psb_err_unit,'(" ")')
write(20,*) 'computed solution on ',np,' processors.' ! write(psb_err_unit,'("Saving x on file")')
write(20,*) 'iterations to convergence: ',iter ! write(20,*) 'matrix: ',mtrx_file
write(20,*) 'error estimate (infinity norm) on exit:', & ! write(20,*) 'computed solution on ',np,' processors.'
& ' ||r||/(||a||||x||+||b||) = ',err ! write(20,*) 'iterations to convergence: ',iter
write(20,'("Residual norm 2 : ",es12.5)')resmx ! write(20,*) 'error estimate (infinity norm) on exit:', &
write(20,'("Residual norm inf : ",es12.5)')resmxp ! & ' ||r||/(||a||||x||+||b||) = ',err
write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)' ! write(20,'("Residual norm 2 : ",es12.5)')resmx
do i=1,m_problem ! write(20,'("Residual norm inf : ",es12.5)')resmxp
write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i) ! write(20,'(a8,4(2x,a20))') 'I','X(I)','R(I)','B(I)'
enddo ! do i=1,m_problem
end if ! write(20,998) i,x_col_glob(i),r_col_glob(i),b_col_glob(i)
! enddo
! end if
998 format(i8,4(2x,g20.14)) 998 format(i8,4(2x,g20.14))
993 format(i6,4(1x,e12.6)) 993 format(i6,4(1x,e12.6))
! call psb_gefree(b_col, desc_a,info)
call psb_gefree(b_col, desc_a,info)
call psb_gefree(x_col, desc_a,info) call psb_gefree(x_col, desc_a,info)
call psb_spfree(a, desc_a,info) call psb_spfree(a, desc_a,info)
call prec%free(info) call prec%free(info)

Write Preview
Loading…
Cancel
Save