fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-12 08:59:04 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
test/fileread/psb_cf_sample.f90
 test/fileread/psb_df_sample.f90
 test/fileread/psb_sf_sample.f90
 test/fileread/psb_zf_sample.f90
 util/psb_c_mat_dist_impl.f90
 util/psb_c_mat_dist_mod.f90
 util/psb_d_mat_dist_impl.f90
 util/psb_d_mat_dist_mod.f90
 util/psb_s_mat_dist_impl.f90
 util/psb_s_mat_dist_mod.f90
 util/psb_z_mat_dist_impl.f90
 util/psb_z_mat_dist_mod.f90


Modified mat_dist and df_sample.
This commit is contained in:
Salvatore Filippone
2017-02-12 20:28:53 +00:00
parent 001aa819fa
commit 240efbc338
12 changed files with 97 additions and 407 deletions
Download Patch File Download Diff File Expand all files Collapse all files
test/fileread/psb_cf_sample.f90
+11 -21
View File
@@ -38,7 +38,7 @@ program psb_cf_sample
implicit none
! input parameters
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file,renum
! sparse matrices
type(psb_cspmat_type) :: a, aux_a
@@ -61,7 +61,7 @@ program psb_cf_sample
integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,&
& methd, istopc, irst
integer(psb_long_int_k_) :: amatsize, precsize, descsize
real(psb_spk_) :: err, eps
real(psb_spk_) :: err, eps, cond
character(len=5) :: afmt
character(len=20) :: name
@@ -160,21 +160,14 @@ program psb_cf_sample
b_col_glob => aux_b(:,1)
do i=1, m_problem
b_col_glob(i) = (1.0,1.0)
b_col_glob(i) = cone
enddo
endif
call psb_bcast(ictxt,b_col_glob(1:m_problem))
else
call psb_bcast(ictxt,m_problem)
call psb_realloc(m_problem,1,aux_b,ircode)
if (ircode /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
endif
b_col_glob =>aux_b(:,1)
call psb_bcast(ictxt,b_col_glob(1:m_problem))
end if
! switch over different partition types
@@ -186,8 +179,7 @@ program psb_cf_sample
call part_block(i,m_problem,np,ipv,nv)
ivg(i) = ipv(1)
enddo
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else if (ipart == 2) then
if (iam == psb_root_) then
@@ -200,20 +192,19 @@ program psb_cf_sample
call psb_barrier(ictxt)
call distr_mtpart(psb_root_,ictxt)
call getv_mtpart(ivg)
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else
if (iam == psb_root_) write(psb_out_unit,'("Partition type: block subroutine")')
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,parts=part_block)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block)
end if
call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_)
call psb_geall(x_col,desc_a,info)
call x_col%set(czero)
call x_col%zero()
call psb_geasb(x_col,desc_a,info)
call psb_geall(r_col,desc_a,info)
call r_col%set(czero)
call r_col%zero()
call psb_geasb(r_col,desc_a,info)
t2 = psb_wtime() - t1
@@ -246,12 +237,12 @@ program psb_cf_sample
write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec
write(psb_out_unit,'(" ")')
end if
iparm = 0
call psb_barrier(ictxt)
t1 = psb_wtime()
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst)
& itmax=itmax,iter=iter,err=err,itrace=itrace,&
& istop=istopc,irst=irst)
call psb_barrier(ictxt)
t2 = psb_wtime() - t1
call psb_amx(ictxt,t2)
@@ -278,7 +269,6 @@ program psb_cf_sample
write(psb_out_unit,'("Total time : ",es12.5)')t2+tprec
write(psb_out_unit,'("Residual norm 2 : ",es12.5)')resmx
write(psb_out_unit,'("Residual norm inf : ",es12.5)')resmxp
!!$ write(psb_out_unit,*)"Condition number : ",cond
write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize
write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize
test/fileread/psb_df_sample.f90
+32 -52
View File
@@ -52,7 +52,6 @@ program psb_df_sample
real(psb_dpk_), pointer :: b_col_glob(:)
type(psb_d_vect_type) :: b_col, x_col, r_col
! communications data structure
type(psb_desc_type):: desc_a
@@ -62,7 +61,7 @@ program psb_df_sample
integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,&
& methd, istopc, irst
integer(psb_long_int_k_) :: amatsize, precsize, descsize
real(psb_dpk_) :: err, eps,cond
real(psb_dpk_) :: err, eps, cond
character(len=5) :: afmt
character(len=20) :: name
@@ -71,7 +70,7 @@ program psb_df_sample
integer(psb_ipk_) :: iparm(20)
! other variables
integer(psb_ipk_) :: i,info,j,m_problem
integer(psb_ipk_) :: i,info,j,m_problem, err_act
integer(psb_ipk_) :: internal, m,ii,nnzero
real(psb_dpk_) :: t1, t2, tprec
real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp
@@ -95,7 +94,6 @@ program psb_df_sample
if(psb_get_errstatus() /= 0) goto 9999
info=psb_success_
call psb_set_errverbosity(itwo)
call psb_cd_set_large_threshold(itwo)
!
! Hello world
!
@@ -142,7 +140,7 @@ program psb_df_sample
m_problem = aux_a%get_nrows()
call psb_bcast(ictxt,m_problem)
call psb_mat_renum(psb_mat_renum_gps_,aux_a,info,perm)
call psb_mat_renum(psb_mat_renum_identity_,aux_a,info,perm)
! At this point aux_b may still be unallocated
if (size(aux_b,dim=1) == m_problem) then
@@ -151,37 +149,25 @@ program psb_df_sample
b_col_glob =>aux_b(:,1)
call psb_gelp('N',perm(1:m_problem),&
& b_col_glob(1:m_problem),info)
write(fnout,'(a,i3.3,a)') 'amat-',iam,'-gps.mtx'
call aux_a%print(fnout)
write(fnout,'(a,i3.3,a)') 'rhs-',iam,'-gps.mtx'
call mm_array_write(b_col_glob(1:m_problem),'GPS RHS',info,filename=fnout)
else
write(psb_out_unit,'("Generating an rhs...")')
write(psb_out_unit,'(" ")')
call psb_realloc(m_problem,1,aux_b,ircode)
if (ircode /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
endif
b_col_glob => aux_b(:,1)
do i=1, m_problem
b_col_glob(i) = 1.d0
enddo
b_col_glob(i) = done
enddo
endif
call psb_bcast(ictxt,b_col_glob(1:m_problem))
else
call psb_bcast(ictxt,m_problem)
call psb_realloc(m_problem,1,aux_b,ircode)
if (ircode /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
endif
b_col_glob =>aux_b(:,1)
call psb_bcast(ictxt,b_col_glob(1:m_problem))
end if
! switch over different partition types
@@ -193,8 +179,7 @@ program psb_df_sample
call part_block(i,m_problem,np,ipv,nv)
ivg(i) = ipv(1)
enddo
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else if (ipart == 2) then
if (iam == psb_root_) then
@@ -207,31 +192,29 @@ program psb_df_sample
call psb_barrier(ictxt)
call distr_mtpart(psb_root_,ictxt)
call getv_mtpart(ivg)
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else
if (iam == psb_root_) write(psb_out_unit,'("Partition type: block subroutine")')
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,parts=part_block)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block)
end if
call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_)
call psb_geall(x_col,desc_a,info)
call x_col%set(dzero)
call x_col%zero()
call psb_geasb(x_col,desc_a,info)
call psb_geall(r_col,desc_a,info)
call r_col%set(dzero)
call r_col%zero()
call psb_geasb(r_col,desc_a,info)
t2 = psb_wtime() - t1
!!$ write(fnout,'(a,i3.3,a)') 'amat-',iam,'.mtx'
!!$ call a%print(fname=fnout)
call psb_amx(ictxt, t2)
if (iam == psb_root_) then
write(psb_out_unit,'(" ")')
write(psb_out_unit,'("Time to read and partition matrix : ",es12.5)')t2
write(psb_out_unit,'(" ")')
write(psb_out_unit,'(" ")')
write(psb_out_unit,'("Time to read and partition matrix : ",es12.5)')t2
write(psb_out_unit,'(" ")')
end if
!
@@ -243,27 +226,26 @@ program psb_df_sample
call psb_precbld(a,desc_a,prec,info)
tprec = psb_wtime()-t1
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld')
goto 9999
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld')
goto 9999
end if
call psb_amx(ictxt, tprec)
call psb_amx(ictxt,tprec)
if(iam == psb_root_) then
write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec
write(psb_out_unit,'(" ")')
write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec
write(psb_out_unit,'(" ")')
end if
cond = dzero
iparm = 0
call psb_barrier(ictxt)
t1 = psb_wtime()
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,&
& irst=irst,cond=cond)
& itmax=itmax,iter=iter,err=err,itrace=itrace,&
& istop=istopc,irst=irst,cond=cond)
call psb_barrier(ictxt)
t2 = psb_wtime() - t1
call psb_amx(ictxt,t2)
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)
@@ -288,14 +270,13 @@ program psb_df_sample
write(psb_out_unit,'("Total time : ",es12.5)')t2+tprec
write(psb_out_unit,'("Residual norm 2 : ",es12.5)')resmx
write(psb_out_unit,'("Residual norm inf : ",es12.5)')resmxp
write(psb_out_unit,*)"Condition number : ",cond
write(psb_out_unit,'("Condition number : ",es12.5)')cond
write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize
write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize
write(psb_out_unit,'("Storage type for DESC_A : ",a)')&
& desc_a%get_fmt()
end if
!!$ call psb_precdump(prec,info,prefix=trim(mtrx_file)//'_')
call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_)
if (info == psb_success_) &
@@ -319,13 +300,12 @@ program psb_df_sample
998 format(i8,4(2x,g20.14))
993 format(i6,4(1x,e12.6))
call psb_gefree(b_col, desc_a,info)
call psb_gefree(x_col, desc_a,info)
call psb_spfree(a, desc_a,info)
call psb_precfree(prec,info)
call psb_cdfree(desc_a,info)
call psb_exit(ictxt)
stop
test/fileread/psb_sf_sample.f90
+31 -44
View File
@@ -38,7 +38,7 @@ program psb_sf_sample
implicit none
! input parameters
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file,renum
! sparse matrices
type(psb_sspmat_type) :: a, aux_a
@@ -52,7 +52,6 @@ program psb_sf_sample
real(psb_spk_), pointer :: b_col_glob(:)
type(psb_s_vect_type) :: b_col, x_col, r_col
! communications data structure
type(psb_desc_type):: desc_a
@@ -62,7 +61,7 @@ program psb_sf_sample
integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,&
& methd, istopc, irst
integer(psb_long_int_k_) :: amatsize, precsize, descsize
real(psb_spk_) :: err, eps,cond
real(psb_spk_) :: err, eps, cond
character(len=5) :: afmt
character(len=20) :: name
@@ -71,7 +70,7 @@ program psb_sf_sample
integer(psb_ipk_) :: iparm(20)
! other variables
integer(psb_ipk_) :: i,info,j,m_problem
integer(psb_ipk_) :: i,info,j,m_problem, err_act
integer(psb_ipk_) :: internal, m,ii,nnzero
real(psb_dpk_) :: t1, t2, tprec
real(psb_spk_) :: r_amax, b_amax, scale,resmx,resmxp
@@ -155,27 +154,20 @@ program psb_sf_sample
write(psb_out_unit,'(" ")')
call psb_realloc(m_problem,1,aux_b,ircode)
if (ircode /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
endif
b_col_glob => aux_b(:,1)
do i=1, m_problem
b_col_glob(i) = 1.d0
enddo
b_col_glob(i) = sone
enddo
endif
call psb_bcast(ictxt,b_col_glob(1:m_problem))
else
call psb_bcast(ictxt,m_problem)
call psb_realloc(m_problem,1,aux_b,ircode)
if (ircode /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
endif
b_col_glob =>aux_b(:,1)
call psb_bcast(ictxt,b_col_glob(1:m_problem))
end if
! switch over different partition types
@@ -187,8 +179,7 @@ program psb_sf_sample
call part_block(i,m_problem,np,ipv,nv)
ivg(i) = ipv(1)
enddo
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else if (ipart == 2) then
if (iam == psb_root_) then
@@ -201,30 +192,29 @@ program psb_sf_sample
call psb_barrier(ictxt)
call distr_mtpart(psb_root_,ictxt)
call getv_mtpart(ivg)
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else
if (iam == psb_root_) write(psb_out_unit,'("Partition type: block subroutine")')
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,parts=part_block)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block)
end if
call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_)
call psb_geall(x_col,desc_a,info)
call x_col%set(szero)
call x_col%zero()
call psb_geasb(x_col,desc_a,info)
call psb_geall(r_col,desc_a,info)
call r_col%set(szero)
call r_col%zero()
call psb_geasb(r_col,desc_a,info)
t2 = psb_wtime() - t1
call psb_amx(ictxt, t2)
if (iam == psb_root_) then
write(psb_out_unit,'(" ")')
write(psb_out_unit,'("Time to read and partition matrix : ",es12.5)')t2
write(psb_out_unit,'(" ")')
write(psb_out_unit,'(" ")')
write(psb_out_unit,'("Time to read and partition matrix : ",es12.5)')t2
write(psb_out_unit,'(" ")')
end if
!
@@ -236,27 +226,26 @@ program psb_sf_sample
call psb_precbld(a,desc_a,prec,info)
tprec = psb_wtime()-t1
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld')
goto 9999
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld')
goto 9999
end if
call psb_amx(ictxt, tprec)
call psb_amx(ictxt,tprec)
if(iam == psb_root_) then
write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec
write(psb_out_unit,'(" ")')
write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec
write(psb_out_unit,'(" ")')
end if
cond = szero
iparm = 0
call psb_barrier(ictxt)
t1 = psb_wtime()
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,&
& irst=irst,cond=cond)
& itmax=itmax,iter=iter,err=err,itrace=itrace,&
& istop=istopc,irst=irst,cond=cond)
call psb_barrier(ictxt)
t2 = psb_wtime() - t1
call psb_amx(ictxt,t2)
call psb_geaxpby(sone,b_col,szero,r_col,desc_a,info)
call psb_spmm(-sone,a,x_col,sone,r_col,desc_a,info)
@@ -281,14 +270,13 @@ program psb_sf_sample
write(psb_out_unit,'("Total time : ",es12.5)')t2+tprec
write(psb_out_unit,'("Residual norm 2 : ",es12.5)')resmx
write(psb_out_unit,'("Residual norm inf : ",es12.5)')resmxp
write(psb_out_unit,*)"Condition number : ",cond
write(psb_out_unit,'("Condition number : ",es12.5)')cond
write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize
write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize
write(psb_out_unit,'("Storage type for DESC_A : ",a)')&
& desc_a%get_fmt()
end if
!!$ call psb_precdump(prec,info,prefix=trim(mtrx_file)//'_')
call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_)
if (info == psb_success_) &
@@ -312,13 +300,12 @@ program psb_sf_sample
998 format(i8,4(2x,g20.14))
993 format(i6,4(1x,e12.6))
call psb_gefree(b_col, desc_a,info)
call psb_gefree(x_col, desc_a,info)
call psb_spfree(a, desc_a,info)
call psb_precfree(prec,info)
call psb_cdfree(desc_a,info)
call psb_exit(ictxt)
stop
test/fileread/psb_zf_sample.f90
+15 -26
View File
@@ -38,7 +38,7 @@ program psb_zf_sample
implicit none
! input parameters
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file
character(len=40) :: kmethd, ptype, mtrx_file, rhs_file,renum
! sparse matrices
type(psb_zspmat_type) :: a, aux_a
@@ -61,7 +61,7 @@ program psb_zf_sample
integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,&
& methd, istopc, irst
integer(psb_long_int_k_) :: amatsize, precsize, descsize
real(psb_dpk_) :: err, eps
real(psb_dpk_) :: err, eps, cond
character(len=5) :: afmt
character(len=20) :: name
@@ -70,7 +70,7 @@ program psb_zf_sample
integer(psb_ipk_) :: iparm(20)
! other variables
integer(psb_ipk_) :: i,info,j,m_problem
integer(psb_ipk_) :: i,info,j,m_problem, err_act
integer(psb_ipk_) :: internal, m,ii,nnzero
real(psb_dpk_) :: t1, t2, tprec
real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp
@@ -154,27 +154,20 @@ program psb_zf_sample
write(psb_out_unit,'(" ")')
call psb_realloc(m_problem,1,aux_b,ircode)
if (ircode /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
endif
b_col_glob => aux_b(:,1)
do i=1, m_problem
b_col_glob(i) = (1.d0,1.d0)
b_col_glob(i) = zone
enddo
endif
call psb_bcast(ictxt,b_col_glob(1:m_problem))
else
call psb_bcast(ictxt,m_problem)
call psb_realloc(m_problem,1,aux_b,ircode)
if (ircode /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
endif
b_col_glob =>aux_b(:,1)
call psb_bcast(ictxt,b_col_glob(1:m_problem))
end if
! switch over different partition types
@@ -186,8 +179,7 @@ program psb_zf_sample
call part_block(i,m_problem,np,ipv,nv)
ivg(i) = ipv(1)
enddo
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else if (ipart == 2) then
if (iam == psb_root_) then
@@ -200,20 +192,19 @@ program psb_zf_sample
call psb_barrier(ictxt)
call distr_mtpart(psb_root_,ictxt)
call getv_mtpart(ivg)
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,v=ivg)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,v=ivg)
else
if (iam == psb_root_) write(psb_out_unit,'("Partition type: block subroutine")')
call psb_matdist(aux_a, a, ictxt, &
& desc_a,info,b_glob=b_col_glob,b=b_col,fmt=afmt,parts=part_block)
call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block)
end if
call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_)
call psb_geall(x_col,desc_a,info)
call x_col%set(zzero)
call x_col%zero()
call psb_geasb(x_col,desc_a,info)
call psb_geall(r_col,desc_a,info)
call r_col%set(zzero)
call r_col%zero()
call psb_geasb(r_col,desc_a,info)
t2 = psb_wtime() - t1
@@ -246,12 +237,12 @@ program psb_zf_sample
write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec
write(psb_out_unit,'(" ")')
end if
iparm = 0
call psb_barrier(ictxt)
t1 = psb_wtime()
call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst)
& itmax=itmax,iter=iter,err=err,itrace=itrace,&
& istop=istopc,irst=irst)
call psb_barrier(ictxt)
t2 = psb_wtime() - t1
call psb_amx(ictxt,t2)
@@ -278,7 +269,6 @@ program psb_zf_sample
write(psb_out_unit,'("Total time : ",es12.5)')t2+tprec
write(psb_out_unit,'("Residual norm 2 : ",es12.5)')resmx
write(psb_out_unit,'("Residual norm inf : ",es12.5)')resmxp
!!$ write(psb_out_unit,*)"Condition number : ",cond
write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize
write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize
@@ -320,7 +310,6 @@ program psb_zf_sample
9999 call psb_error(ictxt)
stop
end program psb_zf_sample
util/psb_c_mat_dist_impl.f90
+1 -50
View File
@@ -30,7 +30,7 @@
!!$
!!$
subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -65,18 +65,6 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,&
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! complex(psb_spk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_c_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! complex(psb_spk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_c_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
! on exit : unchanged.
@@ -91,10 +79,6 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,&
type(psb_cspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: b_glob(:)
type(psb_c_vect_type), optional :: b
complex(psb_spk_), optional :: x_glob(:)
type(psb_c_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_c_base_sparse_mat), optional :: mold
@@ -146,18 +130,6 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,&
call psb_errpush(info,name,a_err=" v, parts")
goto 9999
endif
if ( count((/present(b_glob),present(b)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" b_glob, b")
goto 9999
endif
if ( count((/present(x_glob),present(x)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" x_glob, x")
goto 9999
endif
! broadcast informations to other processors
call psb_bcast(ictxt,nrow, root)
@@ -357,27 +329,6 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,&
goto 9999
end if
if (present(b_glob).and.present(b)) then
call psb_scatter(b_glob,b,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
if (present(x_glob).and.present(x)) then
call psb_scatter(x_glob,x,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
deallocate(iwork)
if (iam == root) write (*, fmt = *) 'end matdist'
util/psb_c_mat_dist_mod.f90
+1 -16
View File
@@ -35,7 +35,7 @@ module psb_c_mat_dist_mod
interface psb_matdist
subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -70,17 +70,6 @@ module psb_c_mat_dist_mod
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! complex(psb_spk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_c_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! complex(psb_spk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_c_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
@@ -96,10 +85,6 @@ module psb_c_mat_dist_mod
type(psb_cspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: b_glob(:)
type(psb_c_vect_type), optional :: b
complex(psb_spk_), optional :: x_glob(:)
type(psb_c_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_c_base_sparse_mat), optional :: mold
util/psb_d_mat_dist_impl.f90
+1 -50
View File
@@ -30,7 +30,7 @@
!!$
!!$
subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -65,18 +65,6 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! real(psb_dpk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_d_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! real(psb_dpk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_d_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
! on exit : unchanged.
@@ -91,10 +79,6 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
type(psb_dspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: b_glob(:)
type(psb_d_vect_type), optional :: b
real(psb_dpk_), optional :: x_glob(:)
type(psb_d_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_d_base_sparse_mat), optional :: mold
@@ -146,18 +130,6 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
call psb_errpush(info,name,a_err=" v, parts")
goto 9999
endif
if ( count((/present(b_glob),present(b)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" b_glob, b")
goto 9999
endif
if ( count((/present(x_glob),present(x)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" x_glob, x")
goto 9999
endif
! broadcast informations to other processors
call psb_bcast(ictxt,nrow, root)
@@ -357,27 +329,6 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
goto 9999
end if
if (present(b_glob).and.present(b)) then
call psb_scatter(b_glob,b,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
if (present(x_glob).and.present(x)) then
call psb_scatter(x_glob,x,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
deallocate(iwork)
if (iam == root) write (*, fmt = *) 'end matdist'
util/psb_d_mat_dist_mod.f90
+1 -16
View File
@@ -35,7 +35,7 @@ module psb_d_mat_dist_mod
interface psb_matdist
subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -70,17 +70,6 @@ module psb_d_mat_dist_mod
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! real(psb_dpk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_d_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! real(psb_dpk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_d_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
@@ -96,10 +85,6 @@ module psb_d_mat_dist_mod
type(psb_dspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: b_glob(:)
type(psb_d_vect_type), optional :: b
real(psb_dpk_), optional :: x_glob(:)
type(psb_d_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_d_base_sparse_mat), optional :: mold
util/psb_s_mat_dist_impl.f90
+1 -50
View File
@@ -30,7 +30,7 @@
!!$
!!$
subroutine psb_smatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -65,18 +65,6 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,&
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! real(psb_spk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_s_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! real(psb_spk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_s_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
! on exit : unchanged.
@@ -91,10 +79,6 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,&
type(psb_sspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: b_glob(:)
type(psb_s_vect_type), optional :: b
real(psb_spk_), optional :: x_glob(:)
type(psb_s_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_s_base_sparse_mat), optional :: mold
@@ -146,18 +130,6 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,&
call psb_errpush(info,name,a_err=" v, parts")
goto 9999
endif
if ( count((/present(b_glob),present(b)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" b_glob, b")
goto 9999
endif
if ( count((/present(x_glob),present(x)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" x_glob, x")
goto 9999
endif
! broadcast informations to other processors
call psb_bcast(ictxt,nrow, root)
@@ -357,27 +329,6 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,&
goto 9999
end if
if (present(b_glob).and.present(b)) then
call psb_scatter(b_glob,b,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
if (present(x_glob).and.present(x)) then
call psb_scatter(x_glob,x,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
deallocate(iwork)
if (iam == root) write (*, fmt = *) 'end matdist'
util/psb_s_mat_dist_mod.f90
+1 -16
View File
@@ -35,7 +35,7 @@ module psb_s_mat_dist_mod
interface psb_matdist
subroutine psb_smatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -70,17 +70,6 @@ module psb_s_mat_dist_mod
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! real(psb_spk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_s_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! real(psb_spk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_s_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
@@ -96,10 +85,6 @@ module psb_s_mat_dist_mod
type(psb_sspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: b_glob(:)
type(psb_s_vect_type), optional :: b
real(psb_spk_), optional :: x_glob(:)
type(psb_s_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_s_base_sparse_mat), optional :: mold
util/psb_z_mat_dist_impl.f90
+1 -50
View File
@@ -30,7 +30,7 @@
!!$
!!$
subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -65,18 +65,6 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,&
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! complex(psb_dpk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_z_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! complex(psb_dpk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_z_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
! on exit : unchanged.
@@ -91,10 +79,6 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,&
type(psb_zspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: b_glob(:)
type(psb_z_vect_type), optional :: b
complex(psb_dpk_), optional :: x_glob(:)
type(psb_z_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_z_base_sparse_mat), optional :: mold
@@ -146,18 +130,6 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,&
call psb_errpush(info,name,a_err=" v, parts")
goto 9999
endif
if ( count((/present(b_glob),present(b)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" b_glob, b")
goto 9999
endif
if ( count((/present(x_glob),present(x)/)) == 1 ) then
info=psb_err_optional_arg_pair_
call psb_errpush(info,name,a_err=" x_glob, x")
goto 9999
endif
! broadcast informations to other processors
call psb_bcast(ictxt,nrow, root)
@@ -357,27 +329,6 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,&
goto 9999
end if
if (present(b_glob).and.present(b)) then
call psb_scatter(b_glob,b,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
if (present(x_glob).and.present(x)) then
call psb_scatter(x_glob,x,desc_a,info,root=root)
if (info /= 0) then
info=psb_err_from_subroutine_
ch_err='psb_scatter'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
deallocate(iwork)
if (iam == root) write (*, fmt = *) 'end matdist'
util/psb_z_mat_dist_mod.f90
+1 -16
View File
@@ -35,7 +35,7 @@ module psb_z_mat_dist_mod
interface psb_matdist
subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,&
& info, b_glob, b, x_glob, x, parts, v, inroot,fmt,mold)
& info, parts, v, inroot,fmt,mold)
!
! an utility subroutine to distribute a matrix among processors
! according to a user defined data distribution, using
@@ -70,17 +70,6 @@ module psb_z_mat_dist_mod
! type (desc_type) :: desc_a
! on exit : the updated array descriptor
!
! complex(psb_dpk_), optional :: b_glob(:)
! on entry: RHS
!
! type(psb_z_vect_type), optional :: b
! on exit : this will contain the local right hand side.
!
! complex(psb_dpk_), optional :: x_glob(:)
! on entry: initial guess
!
! type(psb_z_vect_type), optional :: x
! on exit : this will contain the local right hand side.
!
! integer(psb_ipk_), optional :: inroot
! on entry: specifies processor holding a_glob. default: 0
@@ -96,10 +85,6 @@ module psb_z_mat_dist_mod
type(psb_zspmat_type) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: b_glob(:)
type(psb_z_vect_type), optional :: b
complex(psb_dpk_), optional :: x_glob(:)
type(psb_z_vect_type), optional :: x
integer(psb_ipk_), optional :: inroot
character(len=*), optional :: fmt
class(psb_z_base_sparse_mat), optional :: mold