From a819e8be434bba9d31895a97c1013071ecc04403 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 9 Mar 2006 16:50:56 +0000 Subject: [PATCH] Renaming scheme for GE routines. Also thought to change psb_spalloc into psb_spall for coherence, but then went into conflict with the serial one. Fixed with a kludge, but we need a good one. --- src/comm/psb_dgather.f90 | 2 - src/comm/psb_dscatter.f90 | 2 - src/methd/psb_dbicg.f90 | 50 +-- src/methd/psb_dcg.f90 | 32 +- src/methd/psb_dcgs.f90 | 56 ++-- src/methd/psb_dcgstab.f90 | 67 ++-- src/methd/psb_dcgstabl.f90 | 74 ++--- src/methd/psb_dgmresr.f90 | 42 +-- src/modules/psb_psblas_mod.f90 | 20 +- src/modules/psb_spmat_type.f90 | 16 +- src/modules/psb_tools_mod.f90 | 10 +- src/prec/psb_dasmatbld.f90 | 8 +- src/prec/psb_dbldaggrmat.f90 | 50 +-- src/prec/psb_dilu_bld.f90 | 8 +- src/prec/psb_dilu_fct.f90 | 8 +- src/prec/psb_dmlprc_aply.f90 | 24 +- src/prec/psb_dslu_bld.f90 | 4 +- src/prec/psb_dumf_bld.f90 | 4 +- src/psblas/psb_daxpby.f90 | 6 +- src/serial/psb_dcoins.f90 | 4 +- src/serial/psb_dcsdp.f90 | 16 +- src/serial/psb_dspgtrow.f90 | 14 +- src/serial/psb_dsymbmm.f90 | 2 +- src/serial/psb_dtransp.f90 | 2 +- src/tools/psb_cdovrbld.f90 | 8 +- src/tools/psb_dallc.f90 | 286 ++++++++-------- src/tools/psb_dspalloc.f90 | 4 +- src/tools/psb_dspasb.f90 | 12 +- src/tools/psb_dspcnv.f90 | 4 +- src/tools/psb_dsphalo.f90 | 8 +- test/Fileread/df_sample.f90 | 33 +- test/Fileread/mat_dist.f90 | 590 ++++++++++++++++----------------- test/Fileread/mmio.f90 | 2 +- test/pargen/ppde90.f90 | 31 +- 34 files changed, 747 insertions(+), 752 deletions(-) diff --git a/src/comm/psb_dgather.f90 b/src/comm/psb_dgather.f90 index 52c27df6..31a91048 100644 --- a/src/comm/psb_dgather.f90 +++ b/src/comm/psb_dgather.f90 @@ -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 diff --git a/src/comm/psb_dscatter.f90 b/src/comm/psb_dscatter.f90 index f844a540..13a97bcc 100644 --- a/src/comm/psb_dscatter.f90 +++ b/src/comm/psb_dscatter.f90 @@ -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 diff --git a/src/methd/psb_dbicg.f90 b/src/methd/psb_dbicg.f90 index b83f3543..6d9343fd 100644 --- a/src/methd/psb_dbicg.f90 +++ b/src/methd/psb_dbicg.f90 @@ -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) diff --git a/src/methd/psb_dcg.f90 b/src/methd/psb_dcg.f90 index f45a2ba1..00dfb67d 100644 --- a/src/methd/psb_dcg.f90 +++ b/src/methd/psb_dcg.f90 @@ -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) diff --git a/src/methd/psb_dcgs.f90 b/src/methd/psb_dcgs.f90 index 04bcc311..6fec67d6 100644 --- a/src/methd/psb_dcgs.f90 +++ b/src/methd/psb_dcgs.f90 @@ -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) diff --git a/src/methd/psb_dcgstab.f90 b/src/methd/psb_dcgstab.f90 index dd227259..d63b7429 100644 --- a/src/methd/psb_dcgstab.f90 +++ b/src/methd/psb_dcgstab.f90 @@ -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" ) diff --git a/src/methd/psb_dcgstabl.f90 b/src/methd/psb_dcgstabl.f90 index 678a7aa7..713cf390 100644 --- a/src/methd/psb_dcgstabl.f90 +++ b/src/methd/psb_dcgstabl.f90 @@ -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) diff --git a/src/methd/psb_dgmresr.f90 b/src/methd/psb_dgmresr.f90 index 031a8a18..80d256ba 100644 --- a/src/methd/psb_dgmresr.f90 +++ b/src/methd/psb_dgmresr.f90 @@ -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) diff --git a/src/modules/psb_psblas_mod.f90 b/src/modules/psb_psblas_mod.f90 index 2e814e29..e9af312e 100644 --- a/src/modules/psb_psblas_mod.f90 +++ b/src/modules/psb_psblas_mod.f90 @@ -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 diff --git a/src/modules/psb_spmat_type.f90 b/src/modules/psb_spmat_type.f90 index c9a05d7c..0f22e875 100644 --- a/src/modules/psb_spmat_type.f90 +++ b/src/modules/psb_spmat_type.f90 @@ -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 diff --git a/src/modules/psb_tools_mod.f90 b/src/modules/psb_tools_mod.f90 index ba3706d2..95e6ed7b 100644 --- a/src/modules/psb_tools_mod.f90 +++ b/src/modules/psb_tools_mod.f90 @@ -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 diff --git a/src/prec/psb_dasmatbld.f90 b/src/prec/psb_dasmatbld.f90 index 4e792e6b..94304534 100644 --- a/src/prec/psb_dasmatbld.f90 +++ b/src/prec/psb_dasmatbld.f90 @@ -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 diff --git a/src/prec/psb_dbldaggrmat.f90 b/src/prec/psb_dbldaggrmat.f90 index 49484ca7..1ff997a8 100644 --- a/src/prec/psb_dbldaggrmat.f90 +++ b/src/prec/psb_dbldaggrmat.f90 @@ -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 diff --git a/src/prec/psb_dilu_bld.f90 b/src/prec/psb_dilu_bld.f90 index bf20e340..07865c55 100644 --- a/src/prec/psb_dilu_bld.f90 +++ b/src/prec/psb_dilu_bld.f90 @@ -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) diff --git a/src/prec/psb_dilu_fct.f90 b/src/prec/psb_dilu_fct.f90 index 2718b25e..70345765 100644 --- a/src/prec/psb_dilu_fct.f90 +++ b/src/prec/psb_dilu_fct.f90 @@ -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 diff --git a/src/prec/psb_dmlprc_aply.f90 b/src/prec/psb_dmlprc_aply.f90 index c014791d..ea2ccf51 100644 --- a/src/prec/psb_dmlprc_aply.f90 +++ b/src/prec/psb_dmlprc_aply.f90 @@ -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) diff --git a/src/prec/psb_dslu_bld.f90 b/src/prec/psb_dslu_bld.f90 index 9b422325..ddd8dc5c 100644 --- a/src/prec/psb_dslu_bld.f90 +++ b/src/prec/psb_dslu_bld.f90 @@ -116,10 +116,10 @@ subroutine psb_dslu_bld(a,desc_a,p,info) endif if (nzb > 0 ) then if (size(atmp%aspk) 0 ) then if (size(atmp%aspk)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 diff --git a/src/serial/psb_dcsdp.f90 b/src/serial/psb_dcsdp.f90 index ee791e33..ca4c64df 100644 --- a/src/serial/psb_dcsdp.f90 +++ b/src/serial/psb_dcsdp.f90 @@ -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),& diff --git a/src/serial/psb_dspgtrow.f90 b/src/serial/psb_dspgtrow.f90 index 53d3308e..aafd1238 100644 --- a/src/serial/psb_dspgtrow.f90 +++ b/src/serial/psb_dspgtrow.f90 @@ -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 diff --git a/src/serial/psb_dsymbmm.f90 b/src/serial/psb_dsymbmm.f90 index 0067f5da..58bb5bae 100644 --- a/src/serial/psb_dsymbmm.f90 +++ b/src/serial/psb_dsymbmm.f90 @@ -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,& diff --git a/src/serial/psb_dtransp.f90 b/src/serial/psb_dtransp.f90 index 1c6b7958..9231200c 100644 --- a/src/serial/psb_dtransp.f90 +++ b/src/serial/psb_dtransp.f90 @@ -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) diff --git a/src/tools/psb_cdovrbld.f90 b/src/tools/psb_cdovrbld.f90 index 19834657..6f19aa70 100644 --- a/src/tools/psb_cdovrbld.f90 +++ b/src/tools/psb_cdovrbld.f90 @@ -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 diff --git a/src/tools/psb_dallc.f90 b/src/tools/psb_dallc.f90 index 5acc145d..79359dbe 100644 --- a/src/tools/psb_dallc.f90 +++ b/src/tools/psb_dallc.f90 @@ -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 diff --git a/src/tools/psb_dspalloc.f90 b/src/tools/psb_dspalloc.f90 index 45af6871..456b9f59 100644 --- a/src/tools/psb_dspalloc.f90 +++ b/src/tools/psb_dspalloc.f90 @@ -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 diff --git a/src/tools/psb_dspasb.f90 b/src/tools/psb_dspasb.f90 index a32126d1..8962a476 100644 --- a/src/tools/psb_dspasb.f90 +++ b/src/tools/psb_dspasb.f90 @@ -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 diff --git a/src/tools/psb_dspcnv.f90 b/src/tools/psb_dspcnv.f90 index a59cd4e7..27c7566e 100644 --- a/src/tools/psb_dspcnv.f90 +++ b/src/tools/psb_dspcnv.f90 @@ -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 diff --git a/src/tools/psb_dsphalo.f90 b/src/tools/psb_dsphalo.f90 index 4d2b92be..7b0e4fa8 100644 --- a/src/tools/psb_dsphalo.f90 +++ b/src/tools/psb_dsphalo.f90 @@ -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 diff --git a/test/Fileread/df_sample.f90 b/test/Fileread/df_sample.f90 index 88256fbc..93e7e8ad 100644 --- a/test/Fileread/df_sample.f90 +++ b/test/Fileread/df_sample.f90 @@ -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) diff --git a/test/Fileread/mat_dist.f90 b/test/Fileread/mat_dist.f90 index 52cc1b84..87b421a9 100644 --- a/test/Fileread/mat_dist.f90 +++ b/test/Fileread/mat_dist.f90 @@ -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 diff --git a/test/Fileread/mmio.f90 b/test/Fileread/mmio.f90 index ecc39b23..68b88bb9 100644 --- a/test/Fileread/mmio.f90 +++ b/test/Fileread/mmio.f90 @@ -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 diff --git a/test/pargen/ppde90.f90 b/test/pargen/ppde90.f90 index 280c64eb..60fbe172 100644 --- a/test/pargen/ppde90.f90 +++ b/test/pargen/ppde90.f90 @@ -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.'