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

Renaming scheme for GE routines. Also thought to change psb_spalloc

Browse Source 
into psb_spall for coherence, but then went into conflict with the
serial one. Fixed with a kludge, but we need a good one.
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent e94c5ece1b
commit a819e8be43
34 changed files with 747 additions and 752 deletions
Show Stats Download Patch File Download Diff File

2
src/comm/psb_dgather.f90
Unescape Escape View File

@ -64,7 +64,6 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
real(kind(1.d0)) :: locmax(2), amax
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err
@ -269,7 +268,6 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, lock, maxk, globk, m, k, jlx, ilx, i, j, idx
real(kind(1.d0)) :: locmax(2), amax
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err

2
src/comm/psb_dscatter.f90
Unescape Escape View File

@ -69,7 +69,6 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
& err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos
real(kind(1.d0)) :: locmax(2), amax
real(kind(1.d0)),pointer :: scatterv(:)
integer, pointer :: displ(:), l_t_g_all(:), all_dim(:)
integer :: blacs_pnum
@ -331,7 +330,6 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
& err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, root, k, maxk, icomm, myrank,&
& rootrank, c, pos, ilx, jlx
real(kind(1.d0)) :: locmax(2), amax
real(kind(1.d0)),pointer :: scatterv(:)
integer, pointer :: displ(:), l_t_g_all(:), all_dim(:)
integer :: blacs_pnum

50
src/methd/psb_dbicg.f90
Unescape Escape View File

@ -162,8 +162,8 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
naux=4*n_col
allocate(aux(naux),stat=info)
call psb_dalloc(mglob,9,wwrk,desc_a,info)
call psb_asb(wwrk,desc_a,info)
call psb_geall(mglob,9,wwrk,desc_a,info)
call psb_geasb(wwrk,desc_a,info)
if(info.ne.0) then
info=4011
ch_err='psb_asb'
@ -199,10 +199,10 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
itx = 0
if (listop == 1) then
ani = psb_nrmi(a,desc_a,info)
bni = psb_amax(b,desc_a,info)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
else if (listop == 2) then
bn2 = psb_nrm2(b,desc_a,info)
bn2 = psb_genrm2(b,desc_a,info)
endif
if(info.ne.0) then
@ -218,9 +218,9 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
!!$
if (itx.ge.litmax) exit restart
it = 0
call psb_axpby(one,b,zero,r,desc_a,info)
call psb_geaxpby(one,b,zero,r,desc_a,info)
call psb_spmm(-one,a,x,one,r,desc_a,info,work=aux)
call psb_axpby(one,r,zero,rt,desc_a,info)
call psb_geaxpby(one,r,zero,rt,desc_a,info)
if(info.ne.0) then
info=4011
call psb_errpush(info,name)
@ -230,10 +230,10 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
rho = zero
if (debug) write(*,*) 'on entry to amax: b: ',size(b)
if (listop == 1) then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
else if (listop == 2) then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
endif
if(info.ne.0) then
info=4011
@ -242,7 +242,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
end if
if (listop == 1) then
xni = psb_amax(x,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
if (me.eq.0) write(itrac,'(a,i4,5(2x,es10.4))') 'bicg: ',itx,rerr,rni,bni,&
@ -274,19 +274,19 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
call psb_prc_aply(prec,rt,zt,desc_a,info,trans='t',work=aux)
rho_old = rho
rho = psb_dot(rt,z,desc_a,info)
rho = psb_gedot(rt,z,desc_a,info)
if (rho==zero) then
if (debug) write(0,*) 'bicg itxation breakdown r',rho
exit iteration
endif
if (it==1) then
call psb_axpby(one,z,zero,p,desc_a,info)
call psb_axpby(one,zt,zero,pt,desc_a,info)
call psb_geaxpby(one,z,zero,p,desc_a,info)
call psb_geaxpby(one,zt,zero,pt,desc_a,info)
else
beta = (rho/rho_old)
call psb_axpby(one,z,beta,p,desc_a,info)
call psb_axpby(one,zt,beta,pt,desc_a,info)
call psb_geaxpby(one,z,beta,p,desc_a,info)
call psb_geaxpby(one,zt,beta,pt,desc_a,info)
end if
call psb_spmm(one,a,p,zero,q,desc_a,info,&
@ -294,7 +294,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
call psb_spmm(one,a,pt,zero,qt,desc_a,info,&
& work=aux,trans='t')
sigma = psb_dot(pt,q,desc_a,info)
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma==zero) then
if (debug) write(0,*) 'cgs iteration breakdown s1', sigma
exit iteration
@ -303,20 +303,20 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
alpha = rho/sigma
call psb_axpby(alpha,p,one,x,desc_a,info)
call psb_axpby(-alpha,q,one,r,desc_a,info)
call psb_axpby(-alpha,qt,one,rt,desc_a,info)
call psb_geaxpby(alpha,p,one,x,desc_a,info)
call psb_geaxpby(-alpha,q,one,r,desc_a,info)
call psb_geaxpby(-alpha,qt,one,rt,desc_a,info)
if (listop == 1) then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
else if (listop == 2) then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
endif
if (listop == 1) then
xni = psb_amax(x,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
if (me.eq.0) write(itrac,'(a,i4,5(2x,es10.4))') 'bicg: ',itx,rerr,rni,bni,&
@ -344,7 +344,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
deallocate(aux)
call psb_free(wwrk,desc_a,info)
call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
call blacs_set(icontxt,16,isvch)

32
src/methd/psb_dcg.f90
Unescape Escape View File

@ -149,8 +149,8 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
naux=4*n_col
allocate(aux(naux), stat=info)
call psb_dalloc(mglob,5,wwrk,desc_a,info)
call psb_asb(wwrk,desc_a,info)
call psb_geall(mglob,5,wwrk,desc_a,info)
call psb_geasb(wwrk,desc_a,info)
if (info.ne.0) then
info=4011
call psb_errpush(info,name)
@ -189,7 +189,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
!!$
if (itx>= litmax) exit restart
it = 0
call psb_axpby(one,b,zero,r,desc_a,info)
call psb_geaxpby(one,b,zero,r,desc_a,info)
call psb_spmm(-one,a,x,one,r,desc_a,info,work=aux)
if (info.ne.0) then
info=4011
@ -199,10 +199,10 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
rho = zero
if (listop == 1) then
ani = psb_nrmi(a,desc_a,info)
bni = psb_amax(b,desc_a,info)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
else if (listop == 2) then
bn2 = psb_nrm2(b,desc_a,info)
bn2 = psb_genrm2(b,desc_a,info)
endif
if (info.ne.0) then
info=4011
@ -217,34 +217,34 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
Call psb_prc_aply(prec,r,z,desc_a,info,work=aux)
rho_old = rho
rho = psb_dot(r,z,desc_a,info)
rho = psb_gedot(r,z,desc_a,info)
if (it==1) then
call psb_axpby(one,z,zero,p,desc_a,info)
call psb_geaxpby(one,z,zero,p,desc_a,info)
else
if (rho_old==zero) then
write(0,*) 'CG Iteration breakdown'
exit iteration
endif
beta = rho/rho_old
call psb_axpby(one,z,beta,p,desc_a,info)
call psb_geaxpby(one,z,beta,p,desc_a,info)
end if
call psb_spmm(one,a,p,zero,q,desc_a,info,work=aux)
sigma = psb_dot(p,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma==zero) then
write(0,*) 'CG Iteration breakdown'
exit iteration
endif
alpha = rho/sigma
call psb_axpby(alpha,p,one,x,desc_a,info)
call psb_axpby(-alpha,q,one,r,desc_a,info)
call psb_geaxpby(alpha,p,one,x,desc_a,info)
call psb_geaxpby(-alpha,q,one,r,desc_a,info)
if (listop == 1) Then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
If (itrac /= -1) Then
If (me.Eq.0) Write(itrac,'(a,i4,5(2x,es10.4))') 'cg: ',itx,rerr,rni,bni,&
@ -253,7 +253,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
Else If (listop == 2) Then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
rerr = rni/bn2
If (itrac /= -1) Then
If (me.Eq.0) Write(itrac,'(a,i4,3(2x,es10.4)))') 'cg: ',itx,rerr,rni,bn2
@ -273,7 +273,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
end if
deallocate(aux)
call psb_free(wwrk,desc_a,info)
call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
call blacs_set(icontxt,16,isvch)

56
src/methd/psb_dcgs.f90
Unescape Escape View File

@ -154,8 +154,8 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
naux=4*n_col
Allocate(aux(naux),stat=info)
Call psb_alloc(mglob,11,wwrk,desc_a,info)
Call psb_asb(wwrk,desc_a,info)
Call psb_geall(mglob,11,wwrk,desc_a,info)
Call psb_geasb(wwrk,desc_a,info)
if (info.ne.0) Then
info=4011
call psb_errpush(info,name)
@ -197,10 +197,10 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
itx = 0
if (listop == 1) then
ani = psb_nrmi(a,desc_a,info)
bni = psb_amax(b,desc_a,info)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
else if (listop == 2) then
bn2 = psb_nrm2(b,desc_a,info)
bn2 = psb_genrm2(b,desc_a,info)
endif
if(info/=0)then
info=4011
@ -214,9 +214,9 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
!!$
If (itx.Ge.litmax) Exit restart
it = 0
Call psb_axpby(one,b,zero,r,desc_a,info)
Call psb_geaxpby(one,b,zero,r,desc_a,info)
Call psb_spmm(-one,a,x,one,r,desc_a,info,work=aux)
Call psb_axpby(one,r,zero,rt,desc_a,info)
Call psb_geaxpby(one,r,zero,rt,desc_a,info)
if(info/=0)then
info=4011
call psb_errpush(info,name)
@ -227,15 +227,15 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
If (debug) Write(*,*) 'on entry to amax: b: ',Size(b)
if (listop == 1) then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'cgs: ',&
& itx,rerr,rni,bni,xni,ani
endif
else if (listop == 2) then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
rerr = rni/bn2
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,3(2x,es10.4))') 'cgs: ',itx,rerr,rni,bn2
@ -256,21 +256,21 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
If (debug) Write(*,*) 'iteration: ',itx
rho_old = rho
rho = psb_dot(rt,r,desc_a,info)
rho = psb_gedot(rt,r,desc_a,info)
If (rho==zero) Then
If (debug) Write(0,*) 'cgs iteration breakdown r',rho
Exit iteration
Endif
If (it==1) Then
Call psb_axpby(one,r,zero,uv,desc_a,info)
Call psb_axpby(one,r,zero,p,desc_a,info)
Call psb_geaxpby(one,r,zero,uv,desc_a,info)
Call psb_geaxpby(one,r,zero,p,desc_a,info)
Else
beta = (rho/rho_old)
Call psb_axpby(one,r,zero,uv,desc_a,info)
Call psb_axpby(beta,q,one,uv,desc_a,info)
Call psb_axpby(one,q,beta,p,desc_a,info)
Call psb_axpby(one,uv,beta,p,desc_a,info)
Call psb_geaxpby(one,r,zero,uv,desc_a,info)
Call psb_geaxpby(beta,q,one,uv,desc_a,info)
Call psb_geaxpby(one,q,beta,p,desc_a,info)
Call psb_geaxpby(one,uv,beta,p,desc_a,info)
End If
@ -279,7 +279,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
Call psb_spmm(one,a,f,zero,v,desc_a,info,&
& work=aux)
sigma = psb_dot(rt,v,desc_a,info)
sigma = psb_gedot(rt,v,desc_a,info)
If (sigma==zero) Then
If (debug) Write(0,*) 'cgs iteration breakdown s1', sigma
Exit iteration
@ -287,24 +287,24 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
alpha = rho/sigma
Call psb_axpby(one,uv,zero,q,desc_a,info)
Call psb_axpby(-alpha,v,one,q,desc_a,info)
Call psb_axpby(one,uv,zero,s,desc_a,info)
Call psb_axpby(one,q,one,s,desc_a,info)
Call psb_geaxpby(one,uv,zero,q,desc_a,info)
Call psb_geaxpby(-alpha,v,one,q,desc_a,info)
Call psb_geaxpby(one,uv,zero,s,desc_a,info)
Call psb_geaxpby(one,q,one,s,desc_a,info)
Call psb_prc_aply(prec,s,z,desc_a,info,work=aux)
Call psb_axpby(alpha,z,one,x,desc_a,info)
Call psb_geaxpby(alpha,z,one,x,desc_a,info)
Call psb_spmm(one,a,z,zero,qt,desc_a,info,&
& work=aux)
Call psb_axpby(-alpha,qt,one,r,desc_a,info)
Call psb_geaxpby(-alpha,qt,one,r,desc_a,info)
if (listop == 1) then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'cgs: ',&
@ -313,7 +313,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
else if (listop == 2) then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
rerr = rni/bn2
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,3(2x,es10.4))') 'cgs: ',&
@ -336,7 +336,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
End If
Deallocate(aux)
Call psb_free(wwrk,desc_a,info)
Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
Call blacs_set(icontxt,16,isvch)

67
src/methd/psb_dcgstab.f90
Unescape Escape View File

@ -159,8 +159,8 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
naux=6*n_col
allocate(aux(naux),stat=info)
call psb_alloc(mglob,8,wwrk,desc_a,info)
call psb_asb(wwrk,desc_a,info)
call psb_geall(mglob,8,wwrk,desc_a,info)
call psb_geasb(wwrk,desc_a,info)
if (info /= 0) then
info=4011
call psb_errpush(info,name)
@ -199,10 +199,10 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
itx = 0
If (listop == 1) Then
ani = psb_nrmi(a,desc_a,info)
bni = psb_amax(b,desc_a,info)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
Else If (listop == 2) Then
bn2 = psb_nrm2(b,desc_a,info)
bn2 = psb_genrm2(b,desc_a,info)
Endif
if (info /= 0) Then
info=4011
@ -216,9 +216,9 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
!!$
If (itx >= litmax) Exit restart
it = 0
Call psb_axpby(one,b,zero,r,desc_a,info)
Call psb_geaxpby(one,b,zero,r,desc_a,info)
Call psb_spmm(-one,a,x,one,r,desc_a,info,work=aux)
Call psb_axpby(one,r,zero,q,desc_a,info)
Call psb_geaxpby(one,r,zero,q,desc_a,info)
if (info /= 0) Then
info=4011
call psb_errpush(info,name)
@ -233,10 +233,10 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
! residual
!
If (listop == 1) Then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
Else If (listop == 2) Then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
Endif
if (info /= 0) Then
info=4011
@ -255,7 +255,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
End If
If (listop == 1) Then
xni = psb_amax(x,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
If (itrac /= -1) Then
If (myrow == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'bicgstab: ',itx,rerr,rni,bni,&
@ -283,7 +283,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
If (debug) Write(*,*) 'Iteration: ',itx
rho_old = rho
rho = psb_dot(q,r,desc_a,info)
rho = psb_gedot(q,r,desc_a,info)
!!$ call blacs_barrier(icontxt,'All') ! to be removed
!!$ write(0,'(i2," rho old ",2(f,2x))')myrow,rho,rho_old
!!$ call blacs_barrier(icontxt,'All') ! to be removed
@ -293,11 +293,11 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
Endif
If (it==1) Then
Call psb_axpby(one,r,zero,p,desc_a,info)
Call psb_geaxpby(one,r,zero,p,desc_a,info)
Else
beta = (rho/rho_old)*(alpha/omega)
Call psb_axpby(-omega,v,one,p,desc_a,info)
Call psb_axpby(one,r,beta,p,desc_a,info)
Call psb_geaxpby(-omega,v,one,p,desc_a,info)
Call psb_geaxpby(one,r,beta,p,desc_a,info)
End If
Call psb_prc_aply(prec,p,f,desc_a,info,work=aux)
@ -305,21 +305,21 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
Call psb_spmm(one,a,f,zero,v,desc_a,info,&
& work=aux)
sigma = psb_dot(q,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
If (sigma==zero) Then
If (debug) Write(0,*) 'Bi-CGSTAB Iteration breakdown S1', sigma
Exit iteration
Endif
alpha = rho/sigma
Call psb_axpby(one,r,zero,s,desc_a,info)
Call psb_geaxpby(one,r,zero,s,desc_a,info)
if(info.ne.0) then
call psb_errpush(4010,name,a_err='psb_axpby')
call psb_errpush(4010,name,a_err='psb_geaxpby')
goto 9999
end if
Call psb_axpby(-alpha,v,one,s,desc_a,info)
Call psb_geaxpby(-alpha,v,one,s,desc_a,info)
if(info.ne.0) then
call psb_errpush(4010,name,a_err='psb_axpby')
call psb_errpush(4010,name,a_err='psb_geaxpby')
goto 9999
end if
@ -337,13 +337,13 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
sigma = psb_dot(t,t,desc_a,info)
sigma = psb_gedot(t,t,desc_a,info)
If (sigma==zero) Then
If (debug) Write(0,*) 'BI-CGSTAB ITERATION BREAKDOWN S2', sigma
Exit iteration
Endif
tau = psb_dot(t,s,desc_a,info)
tau = psb_gedot(t,s,desc_a,info)
omega = tau/sigma
If (omega==zero) Then
@ -351,25 +351,26 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
Exit iteration
Endif
Call psb_axpby(alpha,f,one,x,desc_a,info)
Call psb_axpby(omega,z,one,x,desc_a,info)
Call psb_axpby(one,s,zero,r,desc_a,info)
Call psb_axpby(-omega,t,one,r,desc_a,info)
Call psb_geaxpby(alpha,f,one,x,desc_a,info)
Call psb_geaxpby(omega,z,one,x,desc_a,info)
Call psb_geaxpby(one,s,zero,r,desc_a,info)
Call psb_geaxpby(-omega,t,one,r,desc_a,info)
If (listop == 1) Then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
If (itrac /= -1) Then
If (myrow == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'bicgstab: ',itx,rerr,rni,bni,&
&xni,ani
If (myrow == 0) Write(itrac,'(a,i4,5(2x,es10.4))') &
& 'bicgstab: ',itx,rerr,rni,bni,xni,ani
Endif
Else If (listop == 2) Then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
rerr = rni/bn2
If (itrac /= -1) Then
If (myrow == 0) Write(itrac,'(a,i4,3(2x,es10.4)))') 'bicgstab: ',itx,rerr,rni,bn2
If (myrow == 0) Write(itrac,'(a,i4,3(2x,es10.4)))') &
& 'bicgstab: ',itx,rerr,rni,bn2
Endif
Endif
@ -389,7 +390,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
End If
Deallocate(aux)
Call psb_free(wwrk,desc_a,info)
Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour
Call blacs_set(icontxt,16,isvch)
!!$ imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" )

74
src/methd/psb_dcgstabl.f90
Unescape Escape View File

@ -184,12 +184,12 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
call psb_errpush(info,name)
goto 9999
End If
Call psb_alloc(mglob,10,wwrk,desc_a,info)
Call psb_alloc(mglob,nl+1,uh,desc_a,info,js=0)
Call psb_alloc(mglob,nl+1,rh,desc_a,info,js=0)
Call psb_asb(wwrk,desc_a,info)
Call psb_asb(uh,desc_a,info)
Call psb_asb(rh,desc_a,info)
Call psb_geall(mglob,10,wwrk,desc_a,info)
Call psb_geall(mglob,nl+1,uh,desc_a,info,js=0)
Call psb_geall(mglob,nl+1,rh,desc_a,info,js=0)
Call psb_geasb(wwrk,desc_a,info)
Call psb_geasb(uh,desc_a,info)
Call psb_geasb(rh,desc_a,info)
if (info.ne.0) Then
info=4011
call psb_errpush(info,name)
@ -213,10 +213,10 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
Call blacs_set(icontxt,16,ich)
if (listop == 1) then
ani = psb_nrmi(a,desc_a,info)
bni = psb_amax(b,desc_a,info)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
else if (listop == 2) then
bn2 = psb_nrm2(b,desc_a,info)
bn2 = psb_genrm2(b,desc_a,info)
endif
if (info.ne.0) Then
info=4011
@ -234,14 +234,14 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
If (debug) Write(0,*) 'restart: ',itx,it
If (itx.Ge.litmax) Exit restart
it = 0
Call psb_axpby(one,b,zero,r,desc_a,info)
Call psb_geaxpby(one,b,zero,r,desc_a,info)
Call psb_spmm(-one,a,x,one,r,desc_a,info,work=aux)
call psb_prc_aply(prec,r,desc_a,info)
Call psb_axpby(one,r,zero,rt0,desc_a,info)
Call psb_axpby(one,r,zero,rh(:,0),desc_a,info)
Call psb_axpby(zero,r,zero,uh(:,0),desc_a,info)
Call psb_geaxpby(one,r,zero,rt0,desc_a,info)
Call psb_geaxpby(one,r,zero,rh(:,0),desc_a,info)
Call psb_geaxpby(zero,r,zero,uh(:,0),desc_a,info)
if (info.ne.0) Then
info=4011
call psb_errpush(info,name)
@ -255,15 +255,15 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
If (debug) Write(0,*) 'on entry to amax: b: ',Size(b)
if (listop == 1) then
rni = psb_amax(r,desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(r,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'bicgstab(l): ',&
& itx,rerr,rni,bni,xni,ani
endif
else if (listop == 2) then
rni = psb_nrm2(r,desc_a,info)
rni = psb_genrm2(r,desc_a,info)
rerr = rni/bn2
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,3(2x,es10.4))') 'bicgstab(l): ',&
@ -289,7 +289,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
Do j = 0, nl -1
If (debug) Write(0,*) 'bicg part: ',j, nl
rho_old = rho
rho = psb_dot(rh(:,j),rt0,desc_a,info)
rho = psb_gedot(rh(:,j),rt0,desc_a,info)
If (rho==zero) Then
If (debug) Write(0,*) 'bi-cgstab iteration breakdown r',rho
Exit iteration
@ -297,13 +297,13 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
beta = alpha*rho/rho_old
If (debug) Write(0,*) 'bicg part: ',alpha,beta,rho,rho_old
rho_old = rho
Call psb_axpby(one,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
Call psb_geaxpby(one,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
If (debug) Write(0,*) 'bicg part: ',rh(1,0),beta
Call psb_spmm(one,a,uh(:,j),zero,uh(:,j+1),desc_a,info,work=aux)
call psb_prc_aply(prec,uh(:,j+1),desc_a,info)
gamma(j) = psb_dot(uh(:,j+1),rt0,desc_a,info)
gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info)
If (gamma(j)==zero) Then
If (debug) Write(0,*) 'bi-cgstab iteration breakdown s2',gamma(j)
Exit iteration
@ -311,8 +311,8 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
alpha = rho/gamma(j)
If (debug) Write(0,*) 'bicg part: alpha=r/g ',alpha,rho,gamma(j)
Call psb_axpby(-alpha,uh(:,1:j+1),one,rh(:,0:j),desc_a,info)
Call psb_axpby(alpha,uh(:,0),one,x,desc_a,info)
Call psb_geaxpby(-alpha,uh(:,1:j+1),one,rh(:,0:j),desc_a,info)
Call psb_geaxpby(alpha,uh(:,0),one,x,desc_a,info)
Call psb_spmm(one,a,rh(:,j),zero,rh(:,j+1),desc_a,info,work=aux)
call psb_prc_aply(prec,rh(:,j+1),desc_a,info)
@ -322,13 +322,13 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
Do j=1, nl
If (debug) Write(0,*) 'mod g-s part: ',j, nl,rh(1,0)
Do i=1, j-1
taum(i,j) = psb_dot(rh(:,i),rh(:,j),desc_a,info)
taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info)
taum(i,j) = taum(i,j)/sigma(i)
Call psb_axpby(-taum(i,j),rh(:,i),one,rh(:,j),desc_a,info)
Call psb_geaxpby(-taum(i,j),rh(:,i),one,rh(:,j),desc_a,info)
Enddo
If (debug) Write(0,*) 'mod g-s part: dot prod '
sigma(j) = psb_dot(rh(:,j),rh(:,j),desc_a,info)
gamma1(j) = psb_dot(rh(:,0),rh(:,j),desc_a,info)
sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info)
gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info)
If (debug) Write(0,*) 'mod g-s part: gamma1 ', &
&gamma1(j), sigma(j)
gamma1(j) = gamma1(j)/sigma(j)
@ -353,19 +353,19 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
Enddo
If (debug) Write(0,*) 'second solve: ', gamma(:)
Call psb_axpby(gamma(1),rh(:,0),one,x,desc_a,info)
Call psb_axpby(-gamma1(nl),rh(:,nl),one,rh(:,0),desc_a,info)
Call psb_axpby(-gamma(nl),uh(:,nl),one,uh(:,0),desc_a,info)
Call psb_geaxpby(gamma(1),rh(:,0),one,x,desc_a,info)
Call psb_geaxpby(-gamma1(nl),rh(:,nl),one,rh(:,0),desc_a,info)
Call psb_geaxpby(-gamma(nl),uh(:,nl),one,uh(:,0),desc_a,info)
Do j=1, nl-1
Call psb_axpby(-gamma(j),uh(:,j),one,uh(:,0),desc_a,info)
Call psb_axpby(gamma2(j),rh(:,j),one,x,desc_a,info)
Call psb_axpby(-gamma1(j),rh(:,j),one,rh(:,0),desc_a,info)
Call psb_geaxpby(-gamma(j),uh(:,j),one,uh(:,0),desc_a,info)
Call psb_geaxpby(gamma2(j),rh(:,j),one,x,desc_a,info)
Call psb_geaxpby(-gamma1(j),rh(:,j),one,rh(:,0),desc_a,info)
Enddo
if (listop == 1) then
rni = psb_amax(rh(:,0),desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(rh(:,0),desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'bicgstab(l): ',&
@ -374,7 +374,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
else if (listop == 2) then
rni = psb_nrm2(rh(:,0),desc_a,info)
rni = psb_genrm2(rh(:,0),desc_a,info)
rerr = rni/bn2
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,3(2x,es10.4))') 'bicgstab(l): ',&
@ -398,9 +398,9 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
End If
Deallocate(aux)
Call psb_free(wwrk,desc_a,info)
Call psb_free(uh,desc_a,info)
Call psb_free(rh,desc_a,info)
Call psb_gefree(wwrk,desc_a,info)
Call psb_gefree(uh,desc_a,info)
Call psb_gefree(rh,desc_a,info)
! restore external global coherence behaviour
Call blacs_set(icontxt,16,isvch)

42
src/methd/psb_dgmresr.f90
Unescape Escape View File

@ -189,10 +189,10 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
goto 9999
End If
Call psb_alloc(mglob,nl+1,v,desc_a,info)
Call psb_alloc(mglob,w,desc_a,info)
Call psb_asb(v,desc_a,info)
Call psb_asb(w,desc_a,info)
Call psb_geall(mglob,nl+1,v,desc_a,info)
Call psb_geall(mglob,w,desc_a,info)
Call psb_geasb(v,desc_a,info)
Call psb_geasb(w,desc_a,info)
if (info.ne.0) Then
info=4011
call psb_errpush(info,name)
@ -206,10 +206,10 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
Call blacs_set(icontxt,16,ich)
if (listop == 1) then
ani = psb_nrmi(a,desc_a,info)
bni = psb_amax(b,desc_a,info)
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
else if (listop == 2) then
bn2 = psb_nrm2(b,desc_a,info)
bn2 = psb_genrm2(b,desc_a,info)
endif
if (info.ne.0) Then
info=4011
@ -226,7 +226,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
!!$
If (debug) Write(0,*) 'restart: ',itx,it
it = 0
Call psb_axpby(one,b,zero,v(:,1),desc_a,info)
Call psb_geaxpby(one,b,zero,v(:,1),desc_a,info)
if (info.ne.0) Then
info=4011
call psb_errpush(info,name)
@ -235,7 +235,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
Call psb_spmm(-one,a,x,one,v(:,1),desc_a,info,work=aux)
call psb_prc_aply(prec,v(:,1),desc_a,info)
rs(1) = psb_nrm2(v(:,1),desc_a,info)
rs(1) = psb_genrm2(v(:,1),desc_a,info)
if (info.ne.0) Then
info=4011
call psb_errpush(info,name)
@ -246,15 +246,15 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
If (debug) Write(0,*) 'on entry to amax: b: ',Size(b),rs(1),scal
if (listop == 1) then
rni = psb_amax(v(:,1),desc_a,info)
xni = psb_amax(x,desc_a,info)
rni = psb_geamax(v(:,1),desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'gmresr(l): ',&
& itx,rerr,rni,bni,xni,ani
endif
else if (listop == 2) then
rni = psb_nrm2(v(:,1),desc_a,info)
rni = psb_genrm2(v(:,1),desc_a,info)
rerr = rni/bn2
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,3(2x,es10.4))') 'gmresr(l): ',&
@ -282,12 +282,12 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
call psb_prc_aply(prec,w,desc_a,info)
do k = 1, i
h(k,i) = psb_dot(v(:,k),w,desc_a,info)
call psb_axpby(-h(k,i),v(:,k),one,w,desc_a,info)
h(k,i) = psb_gedot(v(:,k),w,desc_a,info)
call psb_geaxpby(-h(k,i),v(:,k),one,w,desc_a,info)
end do
h(i+1,i) = psb_nrm2(w,desc_a,info)
h(i+1,i) = psb_genrm2(w,desc_a,info)
scal=one/h(i+1,i)
call psb_axpby(scal,w,zero,v(:,i+1),desc_a,info)
call psb_geaxpby(scal,w,zero,v(:,i+1),desc_a,info)
do k=2,i
rr(k-1,i) = c(k-1)*h(k-1,i) + s(k-1)*h(k,i)
rr(k,i) = -s(k-1)*h(k-1,i) + c(k-1)*h(k,i)
@ -304,7 +304,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
if (listop == 1) then
rni = abs(rs(i+1))
xni = psb_amax(x,desc_a,info)
xni = psb_geamax(x,desc_a,info)
rerr = rni/(ani*xni+bni)
if (itrac /= -1) then
If (me == 0) Write(itrac,'(a,i4,5(2x,es10.4))') 'gmresr(l): ',&
@ -323,7 +323,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
call dtrsm('l','u','n','n',i,1,one,rr,size(rr,1),rs,nl)
if (debug) write(0,*) 'Rebuild x-> RS:',rs(21:nl)
do k=1, i
call psb_axpby(rs(k),v(:,k),one,x,desc_a,info)
call psb_geaxpby(rs(k),v(:,k),one,x,desc_a,info)
end do
exit restart
end if
@ -333,7 +333,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
call dtrsm('l','u','n','n',nl,1,one,rr,size(rr,1),rs,nl)
if (debug) write(0,*) 'Rebuild x-> RS:',rs(21:nl)
do k=1, nl
call psb_axpby(rs(k),v(:,k),one,x,desc_a,info)
call psb_geaxpby(rs(k),v(:,k),one,x,desc_a,info)
end do
End Do restart
@ -347,8 +347,8 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
Deallocate(aux,h,c,s,rs,rr, stat=info)
Call psb_free(v,desc_a,info)
Call psb_free(w,desc_a,info)
Call psb_gefree(v,desc_a,info)
Call psb_gefree(w,desc_a,info)
! restore external global coherence behaviour
Call blacs_set(icontxt,16,isvch)

20
src/modules/psb_psblas_mod.f90
Unescape Escape View File

@ -31,7 +31,7 @@
module psb_psblas_mod
use psb_comm_mod
interface psb_dot
interface psb_gedot
function psb_ddotv(x, y, desc_a,info)
use psb_descriptor_type
real(kind(1.d0)) :: psb_ddotv
@ -49,7 +49,7 @@ module psb_psblas_mod
end function psb_ddot
end interface
interface psb_dots
interface psb_gedots
subroutine psb_ddotvs(res,x, y, desc_a, info)
use psb_descriptor_type
real(kind(1.d0)), intent(out) :: res
@ -66,7 +66,7 @@ module psb_psblas_mod
end subroutine psb_dmdots
end interface
interface psb_axpby
interface psb_geaxpby
subroutine psb_daxpbyv(alpha, x, beta, y,&
& desc_a, info)
use psb_descriptor_type
@ -88,7 +88,7 @@ module psb_psblas_mod
end subroutine psb_daxpby
end interface
interface psb_amax
interface psb_geamax
function psb_damax(x, desc_a, info, jx)
use psb_descriptor_type
real(kind(1.d0)) psb_damax
@ -106,7 +106,7 @@ module psb_psblas_mod
end function psb_damaxv
end interface
interface psb_amaxs
interface psb_geamaxs
subroutine psb_damaxvs(res,x,desc_a,info)
use psb_descriptor_type
real(kind(1.d0)), intent (out) :: res
@ -124,7 +124,7 @@ module psb_psblas_mod
end subroutine psb_dmamax
end interface
interface psb_asum
interface psb_geasum
function psb_dasum(x, desc_a, info, jx)
use psb_descriptor_type
real(kind(1.d0)) psb_dasum
@ -142,7 +142,7 @@ module psb_psblas_mod
end function psb_dasumv
end interface
interface psb_asums
interface psb_geasums
subroutine psb_dasumvs(res,x,desc_a,info)
use psb_descriptor_type
real(kind(1.d0)), intent (out) :: res
@ -160,7 +160,7 @@ module psb_psblas_mod
end interface
interface psb_nrm2
interface psb_genrm2
function psb_dnrm2(x, desc_a, info, jx)
use psb_descriptor_type
real(kind(1.d0)) psb_dnrm2
@ -178,7 +178,7 @@ module psb_psblas_mod
end function psb_dnrm2v
end interface
interface psb_nrm2s
interface psb_genrm2s
subroutine psb_dnrm2vs(res,x,desc_a,info)
use psb_descriptor_type
real(kind(1.d0)), intent (out) :: res
@ -189,7 +189,7 @@ module psb_psblas_mod
end interface
interface psb_nrmi
interface psb_spnrmi
function psb_dnrmi(a, desc_a,info)
use psb_serial_mod
use psb_descriptor_type

16
src/modules/psb_spmat_type.f90
Unescape Escape View File

@ -60,7 +60,7 @@ module psb_spmat_type
module procedure psb_nullify_dsp
end interface
interface psb_spclone
interface psb_sp_clone
module procedure psb_dspclone
end interface
@ -68,11 +68,11 @@ module psb_spmat_type
module procedure psb_dsp_transfer
end interface
interface psb_spreall
interface psb_sp_reall
module procedure psb_dspreallocate, psb_dspreall3
end interface
interface psb_spall
interface psb_sp_all
module procedure psb_dspallocate, psb_dspall3, psb_dspallmk, psb_dspallmknz
end interface
@ -80,7 +80,7 @@ module psb_spmat_type
! module procedure psb_dspfree
! end interface
interface psb_spreinit
interface psb_sp_reinit
module procedure psb_dspreinit
end interface
@ -129,7 +129,7 @@ contains
return
Endif
if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k
call psb_spreall(a,nnz,info)
call psb_sp_reall(a,nnz,info)
a%pl(1)=0
a%pr(1)=0
@ -161,7 +161,7 @@ contains
if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k
a%m=max(0,m)
a%k=max(0,k)
call psb_spreall(a,nnz,info)
call psb_sp_reall(a,nnz,info)
a%pl(1)=0
a%pr(1)=0
@ -193,7 +193,7 @@ contains
if (debug) write(0,*) 'spall : nnz ',nnz,a%m,a%k
a%m=max(0,m)
a%k=max(0,k)
call psb_spreall(a,nnz,info)
call psb_sp_reall(a,nnz,info)
a%pl(1)=0
a%pr(1)=0
@ -219,7 +219,7 @@ contains
info = 0
call psb_spreall(a, ni1,ni2,nd,info)
call psb_sp_reall(a, ni1,ni2,nd,info)
a%pl(1)=0
a%pr(1)=0

10
src/modules/psb_tools_mod.f90
Unescape Escape View File

@ -31,7 +31,7 @@
Module psb_tools_mod
use psb_const_mod
interface psb_alloc
interface psb_geall
! 2-D double precision version
subroutine psb_dalloc(m, n, x, desc_a, info, js)
use psb_descriptor_type
@ -69,7 +69,7 @@ Module psb_tools_mod
end interface
interface psb_asb
interface psb_geasb
! 2-D double precision version
subroutine psb_dasb(x, desc_a, info)
use psb_descriptor_type
@ -154,7 +154,7 @@ Module psb_tools_mod
end interface
interface psb_free
interface psb_gefree
! 2-D double precision version
subroutine psb_dfree(x, desc_a, info)
use psb_descriptor_type
@ -206,7 +206,7 @@ Module psb_tools_mod
end interface
interface psb_ins
interface psb_geins
! 2-D double precision version
subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
& iblck, jblck)
@ -373,7 +373,7 @@ Module psb_tools_mod
end subroutine psb_cdren
end interface
interface psb_spalloc
interface psb_spall
subroutine psb_dspalloc(a, desc_a, info, nnz)
use psb_descriptor_type
use psb_spmat_type

8
src/prec/psb_dasmatbld.f90
Unescape Escape View File

@ -102,10 +102,10 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! Block Jacobi. Copy the descriptor, just in case we want to
! do the renumbering.
!
call psb_spall(0,0,blk,1,info)
call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then
info=4010
ch_err='psb_spall'
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -143,10 +143,10 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
!
! This is really just Block Jacobi.....
!
call psb_spall(0,0,blk,1,info)
call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then
info=4010
ch_err='psb_spall'
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if

50
src/prec/psb_dbldaggrmat.f90
Unescape Escape View File

@ -159,7 +159,7 @@ contains
goto 9999
end if
call psb_spall(b,nzt,info)
call psb_sp_all(b,nzt,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spall')
goto 9999
@ -231,7 +231,7 @@ contains
end if
irs = b%infoa(psb_nnz_)
call psb_spreall(b,irs,info)
call psb_sp_reall(b,irs,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spreall')
goto 9999
@ -247,7 +247,7 @@ contains
nzbr(myprow+1) = irs
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1)
nzbg = sum(nzbr)
call psb_spall(ntaggr,ntaggr,bg,nzbg,info)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spall')
goto 9999
@ -291,7 +291,7 @@ contains
else if (p%iprcparm(coarse_mat_) == mat_distr_) then
call psb_cddec(naggr,icontxt,desc_p,info)
call psb_spclone(b,bg,info)
call psb_sp_clone(b,bg,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone')
goto 9999
@ -425,22 +425,22 @@ contains
end if
do i=1,size(p%dorig)
if (p%dorig(i) /= zero) then
p%dorig(i) = one / p%dorig(i)
else
p%dorig(i) = one
end if
if (p%dorig(i) /= zero) then
p%dorig(i) = one / p%dorig(i)
else
p%dorig(i) = one
end if
end do
! where (p%dorig /= zero)
! p%dorig = one / p%dorig
! elsewhere
! p%dorig = one
! end where
! where (p%dorig /= zero)
! p%dorig = one / p%dorig
! elsewhere
! p%dorig = one
! end where
! 1. Allocate Ptilde in sparse matrix form
call psb_spall(am4,ncol,info)
call psb_sp_all(am4,ncol,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spall')
goto 9999
@ -481,7 +481,7 @@ contains
goto 9999
end if
call psb_spclone(a,am3,info)
call psb_sp_clone(a,am3,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone')
goto 9999
@ -518,7 +518,7 @@ contains
call dgamx2d(icontxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1)
else
anorm = psb_nrmi(am3,desc_a,info)
anorm = psb_spnrmi(am3,desc_a,info)
endif
omega = 4.d0/(3.d0*anorm)
p%dprcparm(smooth_omega_) = omega
@ -699,7 +699,7 @@ contains
case(mat_distr_)
call psb_spclone(b,bg,info)
call psb_sp_clone(b,bg,info)
if(info /= 0) goto 9999
nzbg = bg%infoa(psb_nnz_)
nzl = bg%infoa(psb_nnz_)
@ -756,7 +756,7 @@ contains
bg%k=desc_p%matrix_data(psb_n_col_)
bg%fida='COO'
bg%descra='G'
call psb_spfree(b,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_spfree')
@ -767,9 +767,9 @@ contains
deallocate(ivall,nzbr,idisp)
! Split BG=M+N N off-diagonal part
call psb_spall(bg%m,bg%k,p%av(ap_nd_),nzl,info)
call psb_sp_all(bg%m,bg%k,p%av(ap_nd_),nzl,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_spall')
call psb_errpush(4010,name,a_err='psb_sp_all')
goto 9999
end if
@ -841,7 +841,7 @@ contains
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1)
nzbg = sum(nzbr)
call psb_spall(ntaggr,ntaggr,bg,nzbg,info)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) goto 9999
@ -886,7 +886,7 @@ contains
case(mat_distr_)
call psb_spclone(b,bg,info)
call psb_sp_clone(b,bg,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone')
goto 9999
@ -911,9 +911,9 @@ contains
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1)
nzbg = sum(nzbr)
call psb_spall(ntaggr,ntaggr,bg,nzbg,info)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_spall')
call psb_errpush(4010,name,a_err='psb_sp_all')
goto 9999
end if

8
src/prec/psb_dilu_bld.f90
Unescape Escape View File

@ -197,11 +197,11 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
p%av(l_pr_)%k = n_row
p%av(u_pr_)%m = n_row
p%av(u_pr_)%k = n_row
call psb_spall(n_row,n_row,p%av(l_pr_),nztota+lovr,info)
call psb_spall(n_row,n_row,p%av(u_pr_),nztota+lovr,info)
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota+lovr,info)
call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota+lovr,info)
if(info/=0) then
info=4010
ch_err='psb_spall'
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -235,7 +235,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
call psb_spinfo(psb_nztotreq_,a,nztota,info)
call psb_spinfo(psb_nztotreq_,blck,nztotb,info)
call psb_spall(atmp,nztota+nztotb,info)
call psb_sp_all(atmp,nztota+nztotb,info)
if(info/=0) then
info=4011
call psb_errpush(info,name)

8
src/prec/psb_dilu_fct.f90
Unescape Escape View File

@ -75,10 +75,10 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck)
end if
call psb_nullify_sp(blck_) ! Why do we need this? Who knows....
call psb_spall(0,0,blck_,1,info)
call psb_sp_all(0,0,blck_,1,info)
if(info.ne.0) then
info=4010
ch_err='psb_spall'
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -156,10 +156,10 @@ contains
trw%m=0
trw%k=0
if(debug) write(0,*)'LUINT Allocating TRW'
call psb_spall(trw,1,info)
call psb_sp_all(trw,1,info)
if(info.ne.0) then
info=4010
ch_err='psb_spall'
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if

24
src/prec/psb_dmlprc_aply.f90
Unescape Escape View File

@ -180,7 +180,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
!
! Finally add back into Y.
!
call psb_axpby(one,ty,one,y,desc_data,info)
call psb_geaxpby(one,ty,one,y,desc_data,info)
if(info /=0) goto 9999
deallocate(tx,ty,tz)
@ -228,7 +228,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
if (debug) write(0,*)' mult_ml_apply omega ',omega
if (debugprt) write(0,*)' mult_ml_apply X: ',X(:)
call psb_axpby(one,x,zero,tx,desc_data,info)
call psb_geaxpby(one,x,zero,tx,desc_data,info)
if(info /=0) then
if (debug) write(0,*)' From axpby1 ',size(x),size(tx),n_row,n_col,nr2l,nrg
call psb_errpush(4010,name,a_err='axpby post_smooth 1')
@ -302,7 +302,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
& work,info)
if(info /=0) goto 9999
call psb_axpby(one,ty,beta,y,desc_data,info)
call psb_geaxpby(one,ty,beta,y,desc_data,info)
if(info /=0) goto 9999
deallocate(tx,ty)
@ -329,8 +329,8 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
! Need temp copies to handle Y<- betaY + K^-1 X
! One of the temp copies is not strictly needed when beta==zero
!
call psb_axpby(one,x,zero,tx,desc_data,info)
call psb_axpby(one,y,zero,ty,desc_data,info)
call psb_geaxpby(one,x,zero,tx,desc_data,info)
call psb_geaxpby(one,y,zero,ty,desc_data,info)
if(info /=0) goto 9999
call psb_baseprc_aply(baseprecv(1),x,zero,tty,desc_data,&
@ -387,7 +387,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_csmm(one,baseprecv(2)%av(sm_pr_),t2l,zero,ty,info)
if(info /=0) goto 9999
call psb_axpby(one,ty,one,tty,desc_data,info)
call psb_geaxpby(one,ty,one,tty,desc_data,info)
if(info /=0) goto 9999
deallocate(tz)
@ -399,7 +399,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if
call psb_axpby(one,tty,beta,y,desc_data,info)
call psb_geaxpby(one,tty,beta,y,desc_data,info)
if(info /=0) goto 9999
deallocate(t2l,w2l,tx,ty,tty)
@ -428,8 +428,8 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
! Need temp copies to handle Y<- betaY + K^-1 X
! One of the temp copies is not strictly needed when beta==zero
!
call psb_axpby(one,x,zero,tx,desc_data,info)
call psb_axpby(one,y,zero,ty,desc_data,info)
call psb_geaxpby(one,x,zero,tx,desc_data,info)
call psb_geaxpby(one,y,zero,ty,desc_data,info)
if(info /=0) goto 9999
call psb_baseprc_aply(baseprecv(1),tx,zero,tty,desc_data,trans,work,info)
@ -479,7 +479,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_csmm(one,baseprecv(2)%av(sm_pr_),t2l,zero,ty,info)
if(info /=0) goto 9999
call psb_axpby(one,ty,one,tty,desc_data,info)
call psb_geaxpby(one,ty,one,tty,desc_data,info)
if(info /=0) goto 9999
else
@ -490,7 +490,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if
call psb_axpby(one,x,zero,tx,desc_data,info)
call psb_geaxpby(one,x,zero,tx,desc_data,info)
if(info /=0) goto 9999
call psb_spmm(-one,baseprecv(2)%aorig,tty,one,tx,desc_data,info,work=work)
@ -498,7 +498,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_baseprc_aply(baseprecv(1),tx,one,tty,desc_data,'N',work,info)
call psb_axpby(one,tty,beta,y,desc_data,info)
call psb_geaxpby(one,tty,beta,y,desc_data,info)
deallocate(t2l,w2l,tx,ty,tty)

4
src/prec/psb_dslu_bld.f90
Unescape Escape View File

@ -116,10 +116,10 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
endif
if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then
call psb_spreall(atmp,nza+nzb,info)
call psb_sp_reall(atmp,nza+nzb,info)
if(info /= 0) then
info=4010
ch_err='psb_spreall'
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if

4
src/prec/psb_dumf_bld.f90
Unescape Escape View File

@ -116,10 +116,10 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
endif
if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then
call psb_spreall(atmp,nza+nzb,info)
call psb_sp_reall(atmp,nza+nzb,info)
if(info /= 0) then
info=4010
ch_err='psb_spreall'
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if

6
src/psblas/psb_daxpby.f90
Unescape Escape View File

@ -69,7 +69,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err
name='psb_daxpby'
name='psb_dgeaxpby'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -194,7 +194,7 @@ end subroutine psb_daxpby
!!$
!!$
!
! Subroutine: psb_daxpbyv
! Subroutine: psb_dgeaxpbyv
! Adds one distributed matrix to another,
!
! Y := beta * Y + alpha * X
@ -226,7 +226,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
character(len=20) :: name, ch_err
logical, parameter :: debug=.true.
name='psb_daxpby'
name='psb_dgeaxpby'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

4
src/serial/psb_dcoins.f90
Unescape Escape View File

@ -108,10 +108,10 @@ subroutine psb_dcoins(nz,ia,ja,val,a,gtl,imin,imax,jmin,jmax,info)
endif
if ((nza+nz)>isza) then
call psb_spreall(a,nza+nz,info)
call psb_sp_reall(a,nza+nz,info)
if(info.ne.izero) then
info=4010
ch_err='psb_spreall'
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif

16
src/serial/psb_dcsdp.f90
Unescape Escape View File

@ -145,7 +145,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
ia1_size=a%infoa(psb_nnz_)
ia2_size=a%m+1
aspk_size=a%infoa(psb_nnz_)
call psb_spreall(b,ia1_size,ia2_size,aspk_size,info)
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
@ -167,7 +167,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
ia1_size=a%infoa(psb_nnz_)
ia2_size=a%m+1
aspk_size=a%infoa(psb_nnz_)
call psb_spreall(b,ia1_size,ia2_size,aspk_size,info)
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
do
call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
@ -191,7 +191,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
goto 9999
endif
call psb_spreall(b,nzr,info,ifc=ifc_)
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
@ -208,7 +208,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('COO')
aspk_size=max(size(a%aspk),a%ia2(a%m+1))
call psb_spreall(b,aspk_size,info)
call psb_sp_reall(b,aspk_size,info)
!!$ write(0,*) 'From DCSDP90:',b%fida,size(b%aspk),info
call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
@ -229,7 +229,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('CSR')
aspk_size=max(size(a%aspk),a%ia2(a%m+1))
call psb_spreall(b,aspk_size,info)
call psb_sp_reall(b,aspk_size,info)
call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
@ -242,7 +242,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('JAD')
call psb_spall(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
@ -288,7 +288,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
goto 9999
endif
call psb_spreall(b,nzr,info,ifc=ifc_)
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
@ -302,7 +302,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('COO')
aspk_size=max(size(a%aspk),a%ia2(a%m+1))
call psb_spreall(b,aspk_size,info)
call psb_sp_reall(b,aspk_size,info)
call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&

14
src/serial/psb_dspgtrow.f90
Unescape Escape View File

@ -156,7 +156,7 @@ contains
end do
if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then
call psb_spreall(b,nzb+nz,iret)
call psb_sp_reall(b,nzb+nz,iret)
endif
k=0
@ -197,7 +197,7 @@ contains
nz = a%ia2(idx+nr) - a%ia2(idx)
if (min(size(b%ia1),size(b%ia2),size(b%aspk)) < nzb+nz) then
call psb_spreall(b,nzb+nz,iret)
call psb_sp_reall(b,nzb+nz,iret)
endif
b%fida='COO'
@ -311,7 +311,7 @@ contains
! Now do the copy.
nz = jp - ip +1
if (size(b%ia1) < nzb+nz) then
call psb_spreall(b,nzb+nz,iret)
call psb_sp_reall(b,nzb+nz,iret)
endif
b%fida='COO'
if (associated(iren)) then
@ -336,7 +336,7 @@ contains
nz = (nza*(lrw-irw+1))/max(a%m,1)
if (size(b%ia1) < nzb+nz) then
call psb_spreall(b,nzb+nz,iret)
call psb_sp_reall(b,nzb+nz,iret)
endif
if (associated(iren)) then
@ -346,7 +346,7 @@ contains
k = k + 1
if (k > nz) then
nz = k
call psb_spreall(b,nzb+nz,iret)
call psb_sp_reall(b,nzb+nz,iret)
end if
b%aspk(nzb+k) = a%aspk(i)
b%ia1(nzb+k) = iren(a%ia1(i))
@ -360,7 +360,7 @@ contains
k = k + 1
if (k > nz) then
nz = k
call psb_spreall(b,nzb+nz,iret)
call psb_sp_reall(b,nzb+nz,iret)
end if
b%aspk(nzb+k) = a%aspk(i)
b%ia1(nzb+k) = (a%ia1(i))
@ -443,7 +443,7 @@ contains
end do
if (size(b%ia1) < nzb+nz) then
call psb_spreall(b,nzb+nz,iret)
call psb_sp_reall(b,nzb+nz,iret)
endif
k=0

2
src/serial/psb_dsymbmm.f90
Unescape Escape View File

@ -54,7 +54,7 @@ subroutine psb_dsymbmm(a,b,c)
endif
allocate(itemp(max(a%m,a%k,b%m,b%k)),stat=info)
nze = max(a%m+1,2*a%m)
call psb_spreall(c,nze,info)
call psb_sp_reall(c,nze,info)
!!$ write(0,*) 'SYMBMM90 ',size(c%pl),size(c%pr)
call symbmm(a%m,a%k,b%k,a%ia2,a%ia1,0,&
& b%ia2,b%ia1,0,&

2
src/serial/psb_dtransp.f90
Unescape Escape View File

@ -56,7 +56,7 @@ subroutine psb_dtransp(a,b,c,fmt)
fmt_='CSR'
endif
if (associated(b%aspk)) call psb_spfree(b,info)
call psb_spclone(a,b,info)
call psb_sp_clone(a,b,info)
if (b%fida=='CSR') then
call psb_ipcsr2coo(b,info)

8
src/tools/psb_cdovrbld.f90
Unescape Escape View File

@ -120,10 +120,10 @@ Subroutine psb_cdovrbld(n_ovr,desc_p,desc_a,a,&
end if
call psb_spall(blk,max(lworks,lworkr),info)
call psb_sp_all(blk,max(lworks,lworkr),info)
if (info.ne.0) then
info=4010
ch_err='psb_spall'
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -399,10 +399,10 @@ Subroutine psb_cdovrbld(n_ovr,desc_p,desc_a,a,&
If((n_elem) > size(blk%ia2)) Then
isz = max((3*size(blk%ia2))/2,(n_elem))
if (debug) write(0,*) myrow,'Realloc blk',isz
call psb_spreall(blk,isz,info)
call psb_sp_reall(blk,isz,info)
if (info.ne.0) then
info=4010
ch_err='psb_spreall'
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if

286
src/tools/psb_dallc.f90
Unescape Escape View File

@ -48,7 +48,7 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
use psb_error_mod
implicit none
!....parameters...
integer, intent(in) :: m,n
real(kind(1.d0)), pointer :: x(:,:)
@ -70,50 +70,50 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
err=0
int_err(1)=0
call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
! ....verify blacs grid correctness..
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol.ne.1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
dectype=desc_a%matrix_data(psb_dec_type_)
!... check m and n parameters....
if (m.lt.0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (n.lt.0) then
info = 10
int_err(1) = 2
int_err(2) = n
call psb_errpush(info,name,int_err)
info = 10
int_err(1) = 2
int_err(2) = n
call psb_errpush(info,name,int_err)
else if (.not.psb_is_ok_dec(dectype)) then
info = 3110
call psb_errpush(info,name)
goto 9999
info = 3110
call psb_errpush(info,name)
goto 9999
else if (m.ne.desc_a%matrix_data(psb_n_)) then
info = 300
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = psb_n_
int_err(5) = desc_a%matrix_data(psb_n_)
call psb_errpush(info,name,int_err)
goto 9999
info = 300
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = psb_n_
int_err(5) = desc_a%matrix_data(psb_n_)
call psb_errpush(info,name,int_err)
goto 9999
endif
if (present(js)) then
j=js
else
@ -121,71 +121,69 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
endif
!global check on m and n parameters
if (myrow.eq.psb_root_) then
exch(1)=m
exch(2)=n
exch(3)=j
call igebs2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree)
exch(1)=m
exch(2)=n
exch(3)=j
call igebs2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree)
else
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, psb_root_, 0)
if (exch(1).ne.m) then
info=550
int_err(1)=1
call psb_errpush(info,name,int_err)
goto 9999
else if (exch(2).ne.n) then
info=550
int_err(1)=2
call psb_errpush(info,name,int_err)
goto 9999
else if (exch(3).ne.j) then
info=550
int_err(1)=3
call psb_errpush(info,name,int_err)
goto 9999
endif
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, psb_root_, 0)
if (exch(1).ne.m) then
info=550
int_err(1)=1
call psb_errpush(info,name,int_err)
goto 9999
else if (exch(2).ne.n) then
info=550
int_err(1)=2
call psb_errpush(info,name,int_err)
goto 9999
else if (exch(3).ne.j) then
info=550
int_err(1)=3
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
!....allocate x .....
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
n_col = max(1,desc_a%matrix_data(psb_n_col_))
allocate(x(n_col,j:j+n-1),stat=info)
! call sprealloc(n_col,j:j+n-1,x,info)
n_col = max(1,desc_a%matrix_data(psb_n_col_))
allocate(x(n_col,j:j+n-1),stat=info)
if (info.ne.0) then
info=4010
ch_err='psb_sprealloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do jj=j,j+n-1
do i=1,n_col
x(i,j) = 0.0d0
end do
end do
info=4010
ch_err='allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do jj=j,j+n-1
do i=1,n_col
x(i,j) = 0.0d0
end do
end do
else if (psb_is_bld_dec(dectype)) then
n_row = max(1,desc_a%matrix_data(psb_n_row_))
allocate(x(n_row,j:j+n-1),stat=info)
! call sprealloc(n_row,j:j+n-1,x,info)
if (info.ne.0) then
info=4010
ch_err='psb_sprealloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do jj=j,j+n-1
do i=1,n_row
x(i,j) = 0.0d0
end do
end do
n_row = max(1,desc_a%matrix_data(psb_n_row_))
allocate(x(n_row,j:j+n-1),stat=info)
if (info.ne.0) then
info=4010
ch_err='allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do jj=j,j+n-1
do i=1,n_row
x(i,j) = 0.0d0
end do
end do
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
@ -238,7 +236,7 @@ subroutine psb_dallocv(m, x, desc_a,info)
use psb_error_mod
implicit none
!....parameters...
integer, intent(in) :: m
real(kind(1.d0)), pointer :: x(:)
@ -257,97 +255,97 @@ subroutine psb_dallocv(m, x, desc_a,info)
info=0
name='psb_dallcv'
call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
! ....verify blacs grid correctness..
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol.ne.1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
dectype=desc_a%matrix_data(psb_dec_type_)
if (debug) write(0,*) 'dall: dectype',dectype
if (debug) write(0,*) 'dall: is_ok? dectype',psb_is_ok_dec(dectype)
!... check m and n parameters....
if (m.lt.0) then
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
info = 10
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (.not.psb_is_ok_dec(dectype)) then
info = 3110
call psb_errpush(info,name)
goto 9999
info = 3110
call psb_errpush(info,name)
goto 9999
else if (m.ne.desc_a%matrix_data(psb_n_)) then
info = 300
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = psb_n_
int_err(5) = desc_a%matrix_data(psb_n_)
call psb_errpush(info,name,int_err)
goto 9999
info = 300
int_err(1) = 1
int_err(2) = m
int_err(3) = 4
int_err(4) = psb_n_
int_err(5) = desc_a%matrix_data(psb_n_)
call psb_errpush(info,name,int_err)
goto 9999
endif
!global check on m and n parameters
if (myrow.eq.psb_root_) then
exch = m
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
exch = m
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
else
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
if (exch .ne. m) then
info = 550
int_err(1) = 1
call psb_errpush(info,name,int_err)
goto 9999
endif
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
if (exch .ne. m) then
info = 550
int_err(1) = 1
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
!....allocate x .....
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
n_col = max(1,desc_a%matrix_data(psb_n_col_))
call psb_realloc(n_col,x,info)
if (info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do i=1,n_col
x(i) = 0.0d0
end do
n_col = max(1,desc_a%matrix_data(psb_n_col_))
call psb_realloc(n_col,x,info)
if (info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do i=1,n_col
x(i) = 0.0d0
end do
else if (psb_is_bld_dec(dectype)) then
n_row = max(1,desc_a%matrix_data(psb_n_row_))
call psb_realloc(n_row,x,info)
if (info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do i=1,n_row
x(i) = 0.0d0
end do
n_row = max(1,desc_a%matrix_data(psb_n_row_))
call psb_realloc(n_row,x,info)
if (info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
do i=1,n_row
x(i) = 0.0d0
end do
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return

4
src/tools/psb_dspalloc.f90
Unescape Escape View File

@ -113,10 +113,10 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
if (debug) write(*,*) 'allocating size:',length_ia1
!....allocate aspk, ia1, ia2.....
call psb_spall(loc_row,loc_row,a,length_ia1,info)
call psb_sp_all(loc_row,loc_row,a,length_ia1,info)
if(info.ne.0) then
info=4010
ch_err='spreall'
ch_err='sp_all'
call psb_errpush(info,name,int_err)
goto 9999
end if

12
src/tools/psb_dspasb.f90
Unescape Escape View File

@ -176,10 +176,10 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
a%m = n_row
a%k = n_col
call psb_spclone(a,atemp,info)
call psb_sp_clone(a,atemp,info)
if(info /= no_err) then
info=4010
ch_err='psb_spclone'
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
@ -204,10 +204,10 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
goto 9999
endif
call psb_spreall(a,ia1_size,ia2_size,aspk_size,info)
call psb_sp_reall(a,ia1_size,ia2_size,aspk_size,info)
if (info /= no_err) then
info=4010
ch_err='psb_spreall'
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
@ -253,13 +253,13 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
! Right now, almost nothing to be done, but this
! may change in the future
! as we revise the implementation of the update routine.
call psb_spall(atemp,1,info)
call psb_sp_all(atemp,1,info)
atemp%m=a%m
atemp%k=a%k
! check on allocation
if (info /= no_err) then
info=4010
ch_err='psb_spall'
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif

4
src/tools/psb_dspcnv.f90
Unescape Escape View File

@ -164,7 +164,7 @@ subroutine psb_dspcnv(a,b,desc_a,info)
b%m=nrow
b%k=n_col
call psb_spall(b,ia1_size,ia2_size,aspk_size,info)
call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info)
allocate(work_dcsdp(l_dcsdp),stat=info)
if (info.ne.0) then
info=2025
@ -193,7 +193,7 @@ subroutine psb_dspcnv(a,b,desc_a,info)
if(info.ne.no_err) then
info=4010
ch_err='spclone'
ch_err='dcsdp'
call psb_errpush(info, name, a_err=ch_err)
goto 9999
end if

8
src/tools/psb_dsphalo.f90
Unescape Escape View File

@ -184,17 +184,17 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt)
Enddo
iszr=sum(rvsz)
call psb_spreall(blk,max(iszr,1),info)
call psb_sp_reall(blk,max(iszr,1),info)
if(debug) write(0,*)me,'SPHALO Sizes:',size(blk%ia1),size(blk%ia2)
if (info /= 0) then
info=4010
ch_err='psb_spreall'
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
mat_recv = iszr
iszs=sum(sdsz)
call psb_spall(0,0,tmp,max(iszs,1),info)
call psb_sp_all(0,0,tmp,max(iszs,1),info)
tmp%fida='COO'
t2 = mpi_wtime()
@ -203,7 +203,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt)
ipx = 1
counter=1
idx = 0
call psb_spreinit(tmp)
call psb_sp_reinit(tmp)
Do
proc=desc_a%halo_index(counter)
if (proc == -1) exit

33
test/Fileread/df_sample.f90
Unescape Escape View File

@ -132,7 +132,7 @@ program df_sample
call readmat(mtrx_file, aux_a, ictxt)
m_problem = aux_a%m
call igebs2d(ictxt,'a',' ',1,1,m_problem,1)
call gebs2d(ictxt,'a',m_problem)
if(rhs_file /= 'NONE') then
! reading an rhs
@ -157,16 +157,16 @@ program df_sample
b_col_glob(i) = 1.d0
enddo
endif
call dgebs2d(ictxt,'a',' ',m_problem,1,b_col_glob,m_problem)
call gebs2d(ictxt,'a',b_col_glob(1:m_problem))
else
call igebr2d(ictxt,'a',' ',1,1,m_problem,1,0,0)
call gebr2d(ictxt,'a',m_problem)
allocate(aux_b(m_problem,1), stat=ircode)
if (ircode /= 0) then
call psb_errpush(4000,name)
goto 9999
endif
b_col_glob =>aux_b(:,1)
call dgebr2d(ictxt,'a',' ',m_problem,1,b_col_glob,m_problem,0,0)
call gebr2d(ictxt,'a',b_col_glob(1:m_problem))
end if
! switch over different partition types
@ -208,17 +208,16 @@ program df_sample
& desc_a,b_col_glob,b_col,info,fmt=afmt)
end if
call psb_alloc(m_problem,x_col,desc_a,info)
call psb_geall(m_problem,x_col,desc_a,info)
x_col(:) =0.0
call psb_asb(x_col,desc_a,info)
call psb_alloc(m_problem,r_col,desc_a,info)
call psb_geasb(x_col,desc_a,info)
call psb_geall(m_problem,r_col,desc_a,info)
r_col(:) =0.0
call psb_asb(r_col,desc_a,info)
call psb_geasb(r_col,desc_a,info)
t2 = mpi_wtime() - t1
call dgamx2d(ictxt, 'a', ' ', ione, ione, t2, ione,&
& t1, t1, -1, -1, -1)
call gamx2d(ictxt, 'a', t2)
if (amroot) then
write(*,'(" ")')
@ -272,7 +271,7 @@ program df_sample
end if
call dgamx2d(ictxt,'a',' ',ione, ione,tprec,ione,t1,t1,-1,-1,-1)
call gamx2d(ictxt,'a',tprec)
if(amroot) then
write(*,'("Preconditioner time: ",es10.4)')tprec
@ -300,11 +299,11 @@ program df_sample
endif
call blacs_barrier(ictxt,'all')
t2 = mpi_wtime() - t1
call dgamx2d(ictxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
call psb_axpby(1.d0,b_col,0.d0,r_col,desc_a,info)
call gamx2d(ictxt,'a',t2)
call psb_geaxpby(1.d0,b_col,0.d0,r_col,desc_a,info)
call psb_spmm(-1.d0,a,x_col,1.d0,r_col,desc_a,info)
call psb_nrm2s(resmx,r_col,desc_a,info)
call psb_amaxs(resmxp,r_col,desc_a,info)
call psb_genrm2s(resmx,r_col,desc_a,info)
call psb_geamaxs(resmxp,r_col,desc_a,info)
!!$ iter=iparm(5)
!!$ err = rparm(2)
@ -346,8 +345,8 @@ program df_sample
993 format(i6,4(1x,e12.6))
call psb_free(b_col, desc_a,info)
call psb_free(x_col, desc_a,info)
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(pre,info)
call psb_cdfree(desc_a,info)

590
test/Fileread/mat_dist.f90
Unescape Escape View File

@ -109,13 +109,13 @@ contains
character(len=5), optional :: fmt
interface
! .....user passed subroutine.....
subroutine parts(global_indx,n,np,pv,nv)
implicit none
integer, intent(in) :: global_indx, n, np
integer, intent(out) :: nv
integer, intent(out) :: pv(*)
end subroutine parts
! .....user passed subroutine.....
subroutine parts(global_indx,n,np,pv,nv)
implicit none
integer, intent(in) :: global_indx, n, np
integer, intent(out) :: nv
integer, intent(out) :: pv(*)
end subroutine parts
end interface
! local variables
@ -139,95 +139,95 @@ contains
! executable statements
if (present(inroot)) then
root = inroot
root = inroot
else
root = 0
root = 0
end if
call blacs_gridinfo(icontxt, nprow, npcol, myprow, mypcol)
if (myprow == root) then
! extract information from a_glob
if (a_glob%fida.ne. 'CSR') then
info=135
ch_err='CSR'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
nrow = a_glob%m
ncol = a_glob%k
if (nrow /= ncol) then
write(0,*) 'a rectangular matrix ? ',nrow,ncol
info=-1
call psb_errpush(info,name)
goto 9999
endif
nnzero = size(a_glob%aspk)
nrhs = 1
! broadcast informations to other processors
call igebs2d(icontxt, 'a', ' ', 1, 1, nrow, 1)
call igebs2d(icontxt, 'a', ' ', 1, 1, ncol, 1)
call igebs2d(icontxt, 'a', ' ', 1, 1, nnzero, 1)
call igebs2d(icontxt, 'a', ' ', 1, 1, nrhs, 1)
! extract information from a_glob
if (a_glob%fida.ne. 'CSR') then
info=135
ch_err='CSR'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
nrow = a_glob%m
ncol = a_glob%k
if (nrow /= ncol) then
write(0,*) 'a rectangular matrix ? ',nrow,ncol
info=-1
call psb_errpush(info,name)
goto 9999
endif
nnzero = size(a_glob%aspk)
nrhs = 1
! broadcast informations to other processors
call gebs2d(icontxt, 'a', nrow)
call gebs2d(icontxt, 'a', ncol)
call gebs2d(icontxt, 'a', nnzero)
call gebs2d(icontxt, 'a', nrhs)
else !(myprow /= root)
! receive informations
call igebr2d(icontxt, 'a', ' ', 1, 1, nrow, 1, root, 0)
call igebr2d(icontxt, 'a', ' ', 1, 1, ncol, 1, root, 0)
call igebr2d(icontxt, 'a', ' ', 1, 1, nnzero, 1, root, 0)
call igebr2d(icontxt, 'a', ' ', 1, 1, nrhs, 1, root, 0)
! receive informations
call gebr2d(icontxt, 'a', nrow)
call gebr2d(icontxt, 'a', ncol)
call gebr2d(icontxt, 'a', nnzero)
call gebr2d(icontxt, 'a', nrhs)
end if ! allocate integer work area
liwork = max(nprow, nrow + ncol)
allocate(iwork(liwork), stat = info)
if (info /= 0) then
info=2025
int_err(1)=liwork
call psb_errpush(info,name,i_err=int_err)
goto 9999
info=2025
int_err(1)=liwork
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
if (myprow == root) then
write (*, fmt = *) 'start matdist',root, size(iwork),&
&nrow, ncol, nnzero,nrhs
write (*, fmt = *) 'start matdist',root, size(iwork),&
&nrow, ncol, nnzero,nrhs
endif
if (newt) then
call psb_cdall(nrow,nrow,parts,icontxt,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_cdall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_cdall(nrow,nrow,parts,icontxt,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_cdall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
call psb_cdall(nrow,nrow,parts,icontxt,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_psdscall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_cdall(nrow,nrow,parts,icontxt,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_psdscall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
call psb_spalloc(a,desc_a,info,nnz=nnzero/nprow)
call psb_spall(a,desc_a,info,nnz=nnzero/nprow)
if(info/=0) then
info=4010
ch_err='psb_psspall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_psspall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_alloc(nrow,b,desc_a,info)
call psb_geall(nrow,b,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_psdsall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_psdsall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
isize = max(3*nb,ncol)
blck%m = nb
blck%k = ncol
call psb_spall(blck,nb*ncol,info)
call psb_sp_all(blck,nb*ncol,info)
if(info/=0) then
info=4010
ch_err='spall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='spall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
blck%fida = 'CSR'
@ -235,247 +235,247 @@ contains
do while (i_count.le.nrow)
call parts(i_count,nrow,nprow,iwork, length_row)
call parts(i_count,nrow,nprow,iwork, length_row)
if (length_row.eq.1) then
j_count = i_count
iproc = iwork(1)
do
j_count = j_count + 1
if (j_count-i_count >= nb) exit
if (j_count > nrow) exit
call parts(j_count,nrow,nprow,iwork, length_row)
if (length_row /= 1 ) exit
if (iwork(1) /= iproc ) exit
end do
if (length_row.eq.1) then
j_count = i_count
iproc = iwork(1)
do
j_count = j_count + 1
if (j_count-i_count >= nb) exit
if (j_count > nrow) exit
call parts(j_count,nrow,nprow,iwork, length_row)
if (length_row /= 1 ) exit
if (iwork(1) /= iproc ) exit
end do
! now we should insert rows i_count..j_count-1
nnr = j_count - i_count
! now we should insert rows i_count..j_count-1
nnr = j_count - i_count
if (myprow == root) then
if (myprow == root) then
do j = i_count, j_count
blck%ia2(j-i_count+1) = a_glob%ia2(j) - &
& a_glob%ia2(i_count) + 1
enddo
do j = i_count, j_count
blck%ia2(j-i_count+1) = a_glob%ia2(j) - &
& a_glob%ia2(i_count) + 1
enddo
k = a_glob%ia2(i_count)
do j = k, a_glob%ia2(j_count)-1
blck%aspk(j-k+1) = a_glob%aspk(j)
blck%ia1(j-k+1) = a_glob%ia1(j)
enddo
k = a_glob%ia2(i_count)
do j = k, a_glob%ia2(j_count)-1
blck%aspk(j-k+1) = a_glob%aspk(j)
blck%ia1(j-k+1) = a_glob%ia1(j)
enddo
ll = blck%ia2(nnr+1) - 1
blck%m = nnr
blck%k = nrow
if (iproc == myprow) then
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_spins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_ins(nnr,b,i_count,b_glob(i_count:j_count-1),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_ins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
call igesd2d(icontxt,1,1,nnr,1,iproc,0)
call igesd2d(icontxt,1,1,ll,1,iproc,0)
call igesd2d(icontxt,nnr+1,1,blck%ia2,nnr+1,iproc,0)
call igesd2d(icontxt,ll,1,blck%ia1,ll,iproc,0)
call dgesd2d(icontxt,ll,1,blck%aspk,ll,iproc,0)
call dgesd2d(icontxt,nnr,1,b_glob(i_count:j_count-1),nnr,iproc,0)
call igerv2d(icontxt,1,1,ll,1,iproc,0)
endif
else if (myprow /= root) then
ll = blck%ia2(nnr+1) - 1
blck%m = nnr
blck%k = nrow
if (iproc == myprow) then
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_spins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_geins(nnr,b,i_count,b_glob(i_count:j_count-1),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_ins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
call igesd2d(icontxt,1,1,nnr,1,iproc,0)
call igesd2d(icontxt,1,1,ll,1,iproc,0)
call igesd2d(icontxt,nnr+1,1,blck%ia2,nnr+1,iproc,0)
call igesd2d(icontxt,ll,1,blck%ia1,ll,iproc,0)
call dgesd2d(icontxt,ll,1,blck%aspk,ll,iproc,0)
call dgesd2d(icontxt,nnr,1,b_glob(i_count:j_count-1),nnr,iproc,0)
call igerv2d(icontxt,1,1,ll,1,iproc,0)
endif
else if (myprow /= root) then
if (iproc == myprow) then
call igerv2d(icontxt,1,1,nnr,1,root,0)
call igerv2d(icontxt,1,1,ll,1,root,0)
if (ll > size(blck%ia1)) then
write(0,*) myprow,'need to reallocate ',ll
call psb_spreall(blck,ll,info)
if(info/=0) then
info=4010
ch_err='psb_spreall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
call igerv2d(icontxt,ll,1,blck%ia1,ll,root,0)
call igerv2d(icontxt,nnr+1,1,blck%ia2,nnr+1,root,0)
call dgerv2d(icontxt,ll,1,blck%aspk,ll,root,0)
call dgerv2d(icontxt,nnr,1,b_glob(i_count:i_count+nnr-1),nnr,root,0)
call igesd2d(icontxt,1,1,ll,1,root,0)
blck%m = nnr
blck%k = nrow
blck%infoa(psb_nnz_) = ll
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psspins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_ins(nnr,b,i_count,b_glob(i_count:i_count+nnr-1),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psdsins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
if (iproc == myprow) then
call igerv2d(icontxt,1,1,nnr,1,root,0)
call igerv2d(icontxt,1,1,ll,1,root,0)
if (ll > size(blck%ia1)) then
write(0,*) myprow,'need to reallocate ',ll
call psb_sp_reall(blck,ll,info)
if(info/=0) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
call igerv2d(icontxt,ll,1,blck%ia1,ll,root,0)
call igerv2d(icontxt,nnr+1,1,blck%ia2,nnr+1,root,0)
call dgerv2d(icontxt,ll,1,blck%aspk,ll,root,0)
call dgerv2d(icontxt,nnr,1,b_glob(i_count:i_count+nnr-1),nnr,root,0)
call igesd2d(icontxt,1,1,ll,1,root,0)
blck%m = nnr
blck%k = nrow
blck%infoa(psb_nnz_) = ll
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psspins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_geins(nnr,b,i_count,b_glob(i_count:i_count+nnr-1),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psdsins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
endif
i_count = j_count
else
write(0,*) myprow,'unexpected turn'
! here processors are counted 1..nprow
do j_count = 1, length_row
k_count = iwork(j_count)
if (myprow == root) then
blck%ia2(1) = 1
blck%ia2(2) = 1
do j = a_glob%ia2(i_count), a_glob%ia2(i_count+1)-1
blck%aspk(blck%ia2(2)) = a_glob%aspk(j)
blck%ia1(blck%ia2(2)) = a_glob%ia1(j)
blck%ia2(2) =blck%ia2(2) + 1
enddo
ll = blck%ia2(2) - 1
if (k_count == myprow) then
blck%infoa(1) = ll
blck%infoa(2) = ll
blck%infoa(3) = 2
blck%infoa(4) = 1
blck%infoa(5) = 1
blck%infoa(6) = 1
blck%m = 1
blck%k = nrow
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psspins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_ins(1,b,i_count,b_glob(i_count:i_count),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psdsins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
call igesd2d(icontxt,1,1,ll,1,k_count,0)
call igesd2d(icontxt,ll,1,blck%ia1,ll,k_count,0)
call dgesd2d(icontxt,ll,1,blck%aspk,ll,k_count,0)
call dgesd2d(icontxt,1,1,b_glob(i_count),1,k_count,0)
call igerv2d(icontxt,1,1,ll,1,k_count,0)
endif
else if (myprow /= root) then
if (k_count == myprow) then
call igerv2d(icontxt,1,1,ll,1,root,0)
blck%ia2(1) = 1
blck%ia2(2) = ll+1
call igerv2d(icontxt,ll,1,blck%ia1,ll,root,0)
call dgerv2d(icontxt,ll,1,blck%aspk,ll,root,0)
call dgerv2d(icontxt,1,1,b_glob(i_count),1,root,0)
call igesd2d(icontxt,1,1,ll,1,root,0)
blck%m = 1
blck%k = nrow
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psspins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_ins(1,b,i_count,b_glob(i_count:i_count),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psdsins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
endif
end do
i_count = i_count + 1
endif
i_count = j_count
else
write(0,*) myprow,'unexpected turn'
! here processors are counted 1..nprow
do j_count = 1, length_row
k_count = iwork(j_count)
if (myprow == root) then
blck%ia2(1) = 1
blck%ia2(2) = 1
do j = a_glob%ia2(i_count), a_glob%ia2(i_count+1)-1
blck%aspk(blck%ia2(2)) = a_glob%aspk(j)
blck%ia1(blck%ia2(2)) = a_glob%ia1(j)
blck%ia2(2) =blck%ia2(2) + 1
enddo
ll = blck%ia2(2) - 1
if (k_count == myprow) then
blck%infoa(1) = ll
blck%infoa(2) = ll
blck%infoa(3) = 2
blck%infoa(4) = 1
blck%infoa(5) = 1
blck%infoa(6) = 1
blck%m = 1
blck%k = nrow
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psspins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_geins(1,b,i_count,b_glob(i_count:i_count),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psdsins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
call igesd2d(icontxt,1,1,ll,1,k_count,0)
call igesd2d(icontxt,ll,1,blck%ia1,ll,k_count,0)
call dgesd2d(icontxt,ll,1,blck%aspk,ll,k_count,0)
call dgesd2d(icontxt,1,1,b_glob(i_count),1,k_count,0)
call igerv2d(icontxt,1,1,ll,1,k_count,0)
endif
else if (myprow /= root) then
if (k_count == myprow) then
call igerv2d(icontxt,1,1,ll,1,root,0)
blck%ia2(1) = 1
blck%ia2(2) = ll+1
call igerv2d(icontxt,ll,1,blck%ia1,ll,root,0)
call dgerv2d(icontxt,ll,1,blck%aspk,ll,root,0)
call dgerv2d(icontxt,1,1,b_glob(i_count),1,root,0)
call igesd2d(icontxt,1,1,ll,1,root,0)
blck%m = 1
blck%k = nrow
call psb_spins(ll,blck%ia1,blck%ia2,blck%aspk,a,desc_a,info)
if(info/=0) then
info=4010
ch_err='psspins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_geins(1,b,i_count,b_glob(i_count:i_count),&
&desc_a,info)
if(info/=0) then
info=4010
ch_err='psdsins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
endif
end do
i_count = i_count + 1
endif
end do
if (present(fmt)) then
afmt=fmt
afmt=fmt
else
afmt = 'CSR'
afmt = 'CSR'
endif
if (newt) then
call blacs_barrier(icontxt,'all')
t0 = mpi_wtime()
call psb_cdasb(desc_a,info)
t1 = mpi_wtime()
if(info/=0)then
info=4010
ch_err='psb_cdasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call blacs_barrier(icontxt,'all')
t2 = mpi_wtime()
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt)
t3 = mpi_wtime()
if(info/=0)then
info=4010
ch_err='psb_spasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (myprow == root) then
write(*,*) 'descriptor assembly: ',t1-t0
write(*,*) 'sparse matrix assembly: ',t3-t2
end if
call blacs_barrier(icontxt,'all')
t0 = mpi_wtime()
call psb_cdasb(desc_a,info)
t1 = mpi_wtime()
if(info/=0)then
info=4010
ch_err='psb_cdasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call blacs_barrier(icontxt,'all')
t2 = mpi_wtime()
call psb_spasb(a,desc_a,info,dup=1,afmt=afmt)
t3 = mpi_wtime()
if(info/=0)then
info=4010
ch_err='psb_spasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (myprow == root) then
write(*,*) 'descriptor assembly: ',t1-t0
write(*,*) 'sparse matrix assembly: ',t3-t2
end if
else
call psb_spasb(a,desc_a,info,afmt=afmt,dup=1)
if(info/=0)then
info=4010
ch_err='psspasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_spasb(a,desc_a,info,afmt=afmt,dup=1)
if(info/=0)then
info=4010
ch_err='psspasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
call psb_asb(b,desc_a,info)
call psb_geasb(b,desc_a,info)
if(info/=0)then
info=4010
ch_err='psdsasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psdsasb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_spfree(blck,info)
if(info/=0)then
info=4010
ch_err='spfree'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='spfree'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
deallocate(iwork)
@ -487,8 +487,8 @@ contains
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(icontxt)
return
call psb_error(icontxt)
return
end if
return
@ -641,14 +641,14 @@ contains
goto 9999
end if
call psb_spalloc(a,desc_a,info,nnz=((nnzero+nprow-1)/nprow))
call psb_spall(a,desc_a,info,nnz=((nnzero+nprow-1)/nprow))
if(info/=0) then
info=4010
ch_err='psb_psspall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_alloc(nrow,b,desc_a,info)
call psb_geall(nrow,b,desc_a,info)
if(info/=0) then
info=4010
ch_err='psb_psdsall'
@ -660,7 +660,7 @@ contains
blck%m = nb
blck%k = ncol
call psb_spall(blck,nb*ncol,info)
call psb_sp_all(blck,nb*ncol,info)
if(info/=0) then
info=4010
ch_err='spall'
@ -689,7 +689,7 @@ contains
if (myprow == root) then
ll = a_glob%ia2(j_count)-a_glob%ia2(i_count)
if (ll > size(blck%aspk)) then
call psb_spreall(blck,ll,info)
call psb_sp_reall(blck,ll,info)
if(info/=0) then
info=4010
ch_err='spreall'
@ -719,7 +719,7 @@ contains
goto 9999
end if
call psb_ins(nnr,b,i_count,b_glob(i_count:j_count-1),&
call psb_geins(nnr,b,i_count,b_glob(i_count:j_count-1),&
&desc_a,info)
if(info/=0) then
info=4010
@ -743,7 +743,7 @@ contains
call igerv2d(icontxt,1,1,ll,1,root,0)
if (ll > size(blck%aspk)) then
write(0,*) myprow,'need to reallocate ',ll
call psb_spreall(blck,ll,info)
call psb_sp_reall(blck,ll,info)
if(info/=0) then
info=4010
ch_err='spreall'
@ -810,7 +810,7 @@ contains
goto 9999
end if
call psb_asb(b,desc_a,info)
call psb_geasb(b,desc_a,info)
if (myprow == root) then
write(*,'("Descriptor assembly : ",es10.4)')t1-t0

2
test/Fileread/mmio.f90
Unescape Escape View File

@ -170,7 +170,7 @@ contains
call desym(nrow, a%aspk, a%ia2, a%ia1, as_loc, ia2_loc,&
& ia1_loc, iwork, nnzero, nzr)
call psb_spreall(a,nzr,ircode)
call psb_sp_reall(a,nzr,ircode)
if (ircode /= 0) goto 993
allocate(tmp(nzr),stat=ircode)
if (ircode /= 0) goto 993

31
test/pargen/ppde90.f90
Unescape Escape View File

@ -150,7 +150,7 @@ program pde90
goto 9999
end if
call dgamx2d(icontxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
call gamx2d(icontxt,'a',t2)
if (iam.eq.0) write(*,'("Overall matrix creation time : ",es10.4)')t2
if (iam.eq.0) write(*,'(" ")')
!
@ -201,7 +201,7 @@ program pde90
tprec = mpi_wtime()-t1
call dgamx2d(icontxt,'a',' ',ione, ione,tprec,ione,t1,t1,-1,-1,-1)
call gamx2d(icontxt,'a',tprec)
if (iam.eq.0) write(*,'("Preconditioner time : ",es10.4)')tprec
if (iam.eq.0) write(*,'(" ")')
@ -238,7 +238,7 @@ program pde90
call blacs_barrier(icontxt,'ALL')
t2 = mpi_wtime() - t1
call dgamx2d(icontxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
call gamx2d(icontxt,'a',t2)
if (iam.eq.0) then
write(*,'(" ")')
@ -252,9 +252,10 @@ program pde90
!
! cleanup storage and exit
!
call psb_free(b,desc_a,info)
call psb_free(x,desc_a,info)
call psb_gefree(b,desc_a,info)
call psb_gefree(x,desc_a,info)
call psb_spfree(a,desc_a,info)
call psb_precfree(pre,info)
call psb_cdfree(desc_a,info)
if(info.ne.0) then
info=4010
@ -486,10 +487,10 @@ contains
if(myprow.eq.psb_root_) write(0,'("Generating Matrix (size=",i0x,")...")')n
call psb_cdall(n,n,parts,icontxt,desc_a,info)
call psb_spalloc(a,desc_a,info,nnz=nnz)
call psb_spall(a,desc_a,info,nnz=nnz)
! define rhs from boundary conditions; also build initial guess
call psb_alloc(n,b,desc_a,info)
call psb_alloc(n,t,desc_a,info)
call psb_geall(n,b,desc_a,info)
call psb_geall(n,t,desc_a,info)
if(info.ne.0) then
info=4010
ch_err='allocation rout.'
@ -661,10 +662,10 @@ contains
!!$ else
!!$ zt(1) = 0.d0
!!$ endif
call psb_ins(1,b,ia,zt(1:1),desc_a,info)
call psb_geins(1,b,ia,zt(1:1),desc_a,info)
if(info.ne.0) exit
zt(1)=0.d0
call psb_ins(1,t,ia,zt(1:1),desc_a,info)
call psb_geins(1,t,ia,zt(1:1),desc_a,info)
if(info.ne.0) exit
end if
end do
@ -694,9 +695,9 @@ contains
goto 9999
end if
call dgamx2d(icontxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
call dgamx2d(icontxt,'a',' ',ione, ione,tins,ione,t1,t1,-1,-1,-1)
call dgamx2d(icontxt,'a',' ',ione, ione,tasb,ione,t1,t1,-1,-1,-1)
call gamx2d(icontxt,'a',t2)
call gamx2d(icontxt,'a',tins)
call gamx2d(icontxt,'a',tasb)
if(myprow.eq.psb_root_) then
write(*,'("The matrix has been generated and assembeld in ",a3," format.")')a%fida(1:3)
@ -705,8 +706,8 @@ contains
write(*,'("-assembly time : ",es10.4)')tasb
end if
call psb_asb(b,desc_a,info)
call psb_asb(t,desc_a,info)
call psb_geasb(b,desc_a,info)
call psb_geasb(t,desc_a,info)
if(info.ne.0) then
info=4010
ch_err='asb rout.'

Write Preview
Loading…
Cancel
Save