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

Merge MLD stuf. Phase 2.

Browse Source
This commit is contained in:
Salvatore Filippone
2007-05-28 12:30:29 +00:00
parent 6fcab933e8
commit 4158c73b0d
40 changed files with 499 additions and 427 deletions
Download Patch File Download Diff File Expand all files Collapse all files
mld_daggrmap_bld.f90
+16 -13
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dgenaggrmap
use psb_prec_mod, mld_protect_name => mld_daggrmap_bld
implicit none
integer, intent(in) :: aggr_type
@@ -57,7 +57,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_dgenaggrmap'
name = 'mld_daggrmap_bld'
call psb_erractionsave(err_act)
!
! Note. At the time being we are ignoring aggr_type
@@ -72,9 +72,10 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info)
if(info.ne.0) then
info=4000
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4025
call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
do i=1, nr
@@ -148,9 +149,10 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
!
allocate(ils(naggr+10),stat=info)
if(info.ne.0) then
info=4000
call psb_errpush(info,name)
goto 9999
info=4025
call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
do i=1, size(ils)
@@ -270,9 +272,10 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
allocate(nlaggr(np),stat=info)
if (info/=0) then
info=4000
call psb_errpush(info,name)
goto 9999
info=4025
call psb_errpush(info,name,i_err=(/np,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
nlaggr(:) = 0
@@ -290,4 +293,4 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
end if
return
end subroutine psb_dgenaggrmap
end subroutine mld_daggrmap_bld
mld_daggrmat_asb.F90
+17 -10
View File
@@ -34,28 +34,30 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dbldaggrmat(a,desc_a,ac,desc_ac,p,info)
subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dbldaggrmat
use psb_prec_mod, mld_protect_name => mld_daggrmat_asb
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_dbaseprc_type), intent(inout), target :: p
type(psb_dspmat_type), intent(inout), target :: ac
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_ac
type(psb_dbaseprc_type), intent(inout), target :: p
integer, intent(out) :: info
logical, parameter :: aggr_dump=.false.
integer ::ictxt,np,me, err_act
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name, ch_err
name='psb_dbldaggrmat'
name='mld_daggrmat_asb'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
icomm = psb_cd_get_mpic(desc_a)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
@@ -134,9 +136,10 @@ contains
naggr = p%nlaggr(me+1)
ntaggr = sum(p%nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
@@ -351,7 +354,9 @@ contains
allocate(nzbr(np), idisp(np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
@@ -388,7 +393,9 @@ contains
!
allocate(p%dorig(nrow),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -958,4 +965,4 @@ contains
end subroutine smooth_aggregate
end subroutine psb_dbldaggrmat
end subroutine mld_daggrmat_asb
mld_dasmat_bld.f90
+4 -4
View File
@@ -51,10 +51,10 @@
!* *
!* *
!*****************************************************************************
Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dasmatbld
use psb_prec_mod, mld_protect_name => mld_dasmat_bld
Implicit None
! .. Array Arguments ..
@@ -78,7 +78,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Logical,Parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err
name='psb_dasmatbld'
name='mld_dasmat_bld'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@@ -234,5 +234,5 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if
Return
End Subroutine psb_dasmatbld
End Subroutine mld_dasmat_bld
mld_dbaseprec_aply.f90
+16 -13
View File
@@ -34,14 +34,14 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
!
! Compute Y <- beta*Y + alpha*K^-1 X
! where K is a a basic preconditioner stored in prec
!
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dbaseprc_aply
use psb_prec_mod, mld_protect_name => mld_dbaseprec_aply
implicit none
@@ -62,7 +62,7 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err
name='psb_dbaseprc_aply'
name='mld_dbaseprec_aply'
info = 0
call psb_erractionsave(err_act)
@@ -96,7 +96,7 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
else
allocate(ww(size(x)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
call psb_errpush(4025,name,i_err=(/size(x),0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
end if
@@ -115,10 +115,10 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case(bjac_)
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then
info=4010
ch_err='psb_bjac_aply'
ch_err='mld_bjac_aply'
goto 9999
end if
@@ -126,7 +126,7 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if (prec%iprcparm(n_ovr_)==0) then
! shortcut: this fixes performance for RAS(0) == BJA
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then
info=4010
ch_err='psb_bjacaply'
@@ -148,7 +148,8 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
aux => work(1:)
allocate(ww(isz),tx(isz),ty(isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
call psb_errpush(4025,name,i_err=(/3*isz,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
else if ((3*isz) <= size(work)) then
@@ -157,7 +158,8 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
ty => work(2*isz+1:3*isz)
allocate(aux(4*isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
call psb_errpush(4025,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -165,7 +167,8 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
allocate(ww(isz),tx(isz),ty(isz),&
&aux(4*isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
call psb_errpush(4025,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -198,10 +201,10 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
endif
call psb_bjac_aply(done,prec,tx,dzero,ty,prec%desc_data,trans,aux,info)
call mld_bjac_aply(done,prec,tx,dzero,ty,prec%desc_data,trans,aux,info)
if(info.ne.0) then
info=4010
ch_err='psb_bjac_aply'
ch_err='mld_bjac_aply'
goto 9999
end if
@@ -264,5 +267,5 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
return
end subroutine psb_dbaseprc_aply
end subroutine mld_dbaseprec_aply
mld_dbaseprec_bld.f90
+10 -10
View File
@@ -34,10 +34,10 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dbaseprc_bld
use psb_prec_mod, mld_protect_name => mld_dbaseprc_bld
Implicit None
@@ -63,7 +63,7 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
info=0
err=0
call psb_erractionsave(err_act)
name = 'psb_dbaseprc_bld'
name = 'mld_dbaseprc_bld'
if (debug) write(0,*) 'Entering baseprc_bld'
info = 0
@@ -110,11 +110,11 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
case (diag_)
call psb_diagsc_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_diagsc_bld'
call mld_diag_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of mld_diag_bld'
if(info /= 0) then
info=4010
ch_err='psb_diagsc_bld'
ch_err='mld_diag_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -137,13 +137,13 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
p%iprcparm(jac_sweeps_) = 1
end if
if (debug) write(0,*)me, ': Calling PSB_BJAC_BLD'
if (debug) write(0,*)me, ': Calling mld_bjac_bld'
if (debug) call psb_barrier(ictxt)
call psb_bjac_bld(a,desc_a,p,iupd,info)
call mld_bjac_bld(a,desc_a,p,iupd,info)
if(info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_bjac_bld')
call psb_errpush(info,name,a_err='mld_bjac_bld')
goto 9999
end if
@@ -169,5 +169,5 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
end if
return
end subroutine psb_dbaseprc_bld
end subroutine mld_dbaseprc_bld
mld_dbjac_aply.f90
+21 -15
View File
@@ -34,7 +34,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
!
! Compute Y <- beta*Y + alpha*K^-1 X
! where K is a a Block Jacobi preconditioner stored in prec
@@ -43,7 +43,7 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
!
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dbjac_aply
use psb_prec_mod, mld_protect_name => mld_dbjac_aply
implicit none
@@ -64,7 +64,7 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err
name='psb_dbjac_aply'
name='mld_dbjac_aply'
info = 0
call psb_erractionsave(err_act)
@@ -90,7 +90,9 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
else
allocate(aux(4*n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -98,7 +100,9 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
else
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
endif
@@ -138,9 +142,9 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
select case(toupper(trans))
case('N')
call psb_dslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
call mld_dslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
case('T','C')
call psb_dslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
call mld_dslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
end select
if(info /=0) goto 9999
@@ -153,9 +157,9 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
select case(toupper(trans))
case('N')
call psb_dsludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
call mld_dsludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
case('T','C')
call psb_dsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
call mld_dsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
end select
if(info /=0) goto 9999
@@ -166,9 +170,9 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
select case(toupper(trans))
case('N')
call psb_dumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
call mld_dumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
case('T','C')
call psb_dumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
call mld_dumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
end select
if(info /=0) goto 9999
@@ -191,7 +195,9 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
allocate(tx(n_col),ty(n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -227,7 +233,7 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
& prec%desc_data,info,work=aux)
if(info /=0) goto 9999
call psb_dslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(slu_ptr_),info)
call mld_dslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(slu_ptr_),info)
if(info /=0) goto 9999
tx(1:n_row) = ty(1:n_row)
end do
@@ -239,7 +245,7 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
& prec%desc_data,info,work=aux)
if(info /=0) goto 9999
call psb_dumf_solve(0,n_row,ww,ty,n_row,&
call mld_dumf_solve(0,n_row,ww,ty,n_row,&
& prec%iprcparm(umf_numptr_),info)
if(info /=0) goto 9999
tx(1:n_row) = ww(1:n_row)
@@ -283,5 +289,5 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
return
end subroutine psb_dbjac_aply
end subroutine mld_dbjac_aply
mld_dbjac_bld.f90
+19 -19
View File
@@ -49,9 +49,9 @@
!* *
!* *
!*****************************************************************************
subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dbjac_bld
use psb_prec_mod, mld_protect_name => mld_dbjac_bld
implicit none
!
! .. Scalar Arguments ..
@@ -77,7 +77,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dbjac_bld'
name='mld_dbjac_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -106,9 +106,9 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
t1= psb_wtime()
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if(debug) write(0,*)me,': calling mld_asmat_bld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if (debug) call psb_barrier(ictxt)
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
call mld_asmat_bld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=coofmt)
if (debugprt) then
@@ -121,12 +121,12 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
endif
if(info/=0) then
call psb_errpush(4010,name,a_err='psb_asmatbld')
call psb_errpush(4010,name,a_err='mld_asmat_bld')
goto 9999
end if
t2= psb_wtime()
if (debug) write(0,*)me,': out of psb_asmatbld'
if (debug) write(0,*)me,': out of mld_asmat_bld'
if (debug) call psb_barrier(ictxt)
@@ -139,10 +139,10 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
! Done inside sp_renum.
!
call psb_sp_renum(a,desc_a,blck,p,atmp,info)
call mld_sp_renum(a,desc_a,blck,p,atmp,info)
if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_renum')
call psb_errpush(4010,name,a_err='mld_sp_renum')
goto 9999
end if
@@ -190,10 +190,10 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_ilu_bld(atmp,p%desc_data,p,upd,info)
call mld_ilu_bld(atmp,p%desc_data,p,upd,info)
if (info/=0) then
call psb_errpush(4010,name,a_err='psb_ilu_bld')
call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999
end if
@@ -221,7 +221,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_slu_bld(atmp,p%desc_data,p,info)
call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='slu_bld')
goto 9999
@@ -235,7 +235,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_umf_bld(atmp,p%desc_data,p,info)
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if (info /= 0) then
call psb_errpush(4010,name,a_err='umf_bld')
@@ -312,10 +312,10 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_ilu_bld(a,desc_a,p,upd,info,blck=blck)
call mld_ilu_bld(a,desc_a,p,upd,info,blck=blck)
if(info/=0) then
call psb_errpush(4010,name,a_err='psb_ilu_bld')
call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999
end if
@@ -373,7 +373,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
endif
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call psb_slu_bld(atmp,p%desc_data,p,info)
if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='slu_bld')
goto 9999
@@ -426,7 +426,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
!!$ nztmp = psb_sp_get_nnzeros(atmp)
!!$ call psb_loc_to_glob(atmp%ia2(1:nztmp),p%desc_data,info,iact='I')
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call psb_sludist_bld(atmp,p%desc_data,p,info)
if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='slu_bld')
goto 9999
@@ -484,7 +484,7 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_umf_bld(atmp,p%desc_data,p,info)
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if (info /= 0) then
call psb_errpush(4010,name,a_err='umf_bld')
@@ -539,6 +539,6 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
return
end subroutine psb_dbjac_bld
end subroutine mld_dbjac_bld
mld_ddiagsc_bld.f90
+10 -7
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
subroutine mld_ddiag_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_ddiagsc_bld
use psb_prec_mod, mld_protect_name => mld_ddiag_bld
Implicit None
type(psb_dspmat_type), target :: a
@@ -61,7 +61,7 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
info=0
err=0
call psb_erractionsave(err_act)
name = 'psb_ddiagsc_bld'
name = 'mld_ddiag_bld'
if (debug) write(0,*) 'Entering diagsc_bld'
info = 0
@@ -112,8 +112,9 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
if (a%pl(1) /= 0) then
allocate(work(n_row),stat=info)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
info=4025
call psb_errpush(info,name,i_err=(/n_row,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
call psb_gelp('n',a%pl,p%d,desc_a,info)
@@ -130,7 +131,9 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
if (debug) then
allocate(gd(mglob),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/mglob,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -164,5 +167,5 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
end if
return
end subroutine psb_ddiagsc_bld
end subroutine mld_ddiag_bld
mld_dilu_bld.f90
+6 -6
View File
@@ -49,9 +49,9 @@
!* *
!* *
!*****************************************************************************
subroutine psb_dilu_bld(a,desc_a,p,upd,info,blck)
subroutine mld_dilu_bld(a,desc_a,p,upd,info,blck)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dilu_bld
use psb_prec_mod, mld_protect_name => mld_dilu_bld
implicit none
!
@@ -77,7 +77,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info,blck)
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dilu_bld'
name='mld_dilu_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -149,10 +149,10 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info,blck)
! Ok, factor the matrix.
!
t5 = psb_wtime()
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
call mld_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
if(info/=0) then
info=4010
ch_err='psb_ilu_fct'
ch_err='mld_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -206,6 +206,6 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info,blck)
return
end subroutine psb_dilu_bld
end subroutine mld_dilu_bld
mld_dilu_fct.f90
+8 -8
View File
@@ -34,7 +34,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dilu_fct(a,l,u,d,info,blck)
subroutine mld_dilu_fct(a,l,u,d,info,blck)
!
! This routine copies and factors "on the fly" from A and BLCK
@@ -58,7 +58,7 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck)
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_dilu_fct'
name='mld_dilu_fct'
info = 0
call psb_erractionsave(err_act)
! .. Executable Statements ..
@@ -86,11 +86,11 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck)
endif
!!$ write(0,*) 'ilu_fct: ',size(l%ia2),size(u%ia2),a%m,blck_%m
call psb_dilu_fctint(m,a%m,a,blck_%m,blck_,&
call mld_dilu_fctint(m,a%m,a,blck_%m,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
if(info.ne.0) then
info=4010
ch_err='psb_dilu_fctint'
ch_err='mld_dilu_fctint'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -130,7 +130,7 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck)
return
contains
subroutine psb_dilu_fctint(m,ma,a,mb,b,&
subroutine mld_dilu_fctint(m,ma,a,mb,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info)
implicit none
@@ -147,7 +147,7 @@ contains
integer :: int_err(5)
character(len=20) :: name, ch_err
name='psb_dilu_fctint'
name='mld_dilu_fctint'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@@ -472,5 +472,5 @@ contains
return
end if
return
end subroutine psb_dilu_fctint
end subroutine psb_dilu_fct
end subroutine mld_dilu_fctint
end subroutine mld_dilu_fct
mld_dmlprec_aply.f90
+48 -35
View File
@@ -34,7 +34,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
!
! Compute Y <- beta*Y + alpha*K^-1 X
! where K is a multilevel preconditioner stored in baseprecv
@@ -55,7 +55,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! as many subdomains as there are processes (except for the coarsest level where
! we might have a replicated index space). Thus the sum apparently disappears
! from our code, but only apparently, because it is implicit in the call
! to psb_baseprc_aply.
! to mld_baseprec_aply.
!
! A bit of description of the baseprecv(:) data structure:
! 1. Number of levels = NLEV = size(baseprecv(:))
@@ -84,7 +84,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
!
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dmlprc_aply
use psb_prec_mod, mld_protect_name => mld_dmlprec_aply
implicit none
type(psb_desc_type),intent(in) :: desc_data
@@ -112,10 +112,9 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end type psb_mlprec_wrk_type
type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:)
name='psb_dmlprc_aply'
name='mld_dmlprec_aply'
info = 0
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_data)
call psb_info(ictxt, me, np)
@@ -156,10 +155,17 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! 1..NLEV <=> (j) <-> 0
call psb_baseprc_aply(alpha,baseprecv(1),x,beta,y,&
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info)
if(info /=0) goto 9999
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)))
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/size(x)+size(y),0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(1)%x2l(:) = x(:)
@@ -172,7 +178,9 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev)%tx(max(n_row,n_col)),&
& mlprec_wrk(ilev)%ty(max(n_row,n_col)), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -214,7 +222,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',icm
endif
call psb_baseprc_aply(done,baseprecv(ilev),&
call mld_baseprec_aply(done,baseprecv(ilev),&
& mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%desc_data, 'N',work,info)
@@ -260,7 +268,6 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(post_smooth_)
!
! Post smoothing.
! 1. X(1) = Xext
@@ -288,7 +295,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(1)%tx(nc2l), stat=info)
mlprec_wrk(1)%x2l(:) = dzero
mlprec_wrk(1)%y2l(:) = dzero
mlprec_wrk(1)%tx(:) = dzero
mlprec_wrk(1)%tx(:) = dzero
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
@@ -313,7 +320,9 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -370,7 +379,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
enddo
call psb_baseprc_aply(done,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
call mld_baseprec_aply(done,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& dzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info)
if(info /=0) goto 9999
@@ -405,7 +414,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if(info /=0) goto 9999
@@ -419,7 +428,6 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(pre_smooth_)
!
! Pre smoothing.
! 1. X(1) = Xext
@@ -444,14 +452,16 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(1)%y2l(:) = dzero
mlprec_wrk(1)%x2l(:) = x
call psb_baseprc_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
call mld_baseprec_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
& dzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,&
& trans,work,info)
@@ -474,10 +484,10 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -517,7 +527,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
endif
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
if(info /=0) goto 9999
@@ -590,22 +600,24 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(1)%x2l(:) = dzero
mlprec_wrk(1)%y2l(:) = dzero
mlprec_wrk(1)%tx(:) = dzero
mlprec_wrk(1)%ty(:) = dzero
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
call psb_baseprc_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
call mld_baseprec_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
& dzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,&
& trans,work,info)
@@ -628,18 +640,19 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(ilev)%ty(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(ilev)%x2l(:) = dzero
mlprec_wrk(ilev)%y2l(:) = dzero
mlprec_wrk(ilev)%tx(:) = dzero
mlprec_wrk(ilev)%ty(:) = dzero
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
if (ismth /= no_smth_) then
!
!Smoothed Aggregation
@@ -674,7 +687,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& baseprecv(ilev)%base_desc,info)
if(info /=0) goto 9999
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
if(info /=0) goto 9999
@@ -715,7 +728,7 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_baseprc_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if(info /=0) goto 9999
@@ -775,5 +788,5 @@ subroutine psb_dmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
!!$ end do
!!$ end subroutine mlprec_wrk_free
end subroutine psb_dmlprc_aply
end subroutine mld_dmlprec_aply
mld_dmlprec_bld.f90
+8 -8
View File
@@ -34,10 +34,10 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dmlprc_bld(a,desc_a,p,info)
subroutine mld_dmlprec_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dmlprc_bld
use psb_prec_mod, mld_protect_name => mld_dmlprec_bld
implicit none
type(psb_dspmat_type), intent(in), target :: a
@@ -94,7 +94,7 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
! Currently this is ignored by gen_aggrmap, but it could be
! changed in the future. Need to package nlaggr & mlia in a
! private data structure?
call psb_genaggrmap(p%iprcparm(aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info)
call mld_aggrmap_bld(p%iprcparm(aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then
info=4010
ch_err='psb_gen_aggrmap'
@@ -105,7 +105,7 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
call psb_nullify_desc(desc_ac)
call psb_bldaggrmat(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then
info=4010
ch_err='psb_bld_aggrmat'
@@ -116,11 +116,11 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
call psb_baseprc_bld(ac,desc_ac,p,info)
call mld_baseprc_bld(ac,desc_ac,p,info)
if (debug) write(0,*) 'Out from baseprcbld',info
if(info /= 0) then
info=4010
ch_err='psb_baseprc_bld'
ch_err='mld_baseprc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -128,7 +128,7 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
!
! We have used a separate ac because:
! 1. We want to reuse the same routines psb_ilu_bld etc.
! 1. We want to reuse the same routines mld_ilu_bld etc.
! 2. We do NOT want to pass an argument twice to them
! p%av(ac_) and p, as this would violate the Fortran standard
! Hence a separate AC and a TRANSFER function at the end.
@@ -156,4 +156,4 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
end if
Return
end subroutine psb_dmlprc_bld
end subroutine mld_dmlprec_bld
mld_dprec_aply.f90
+14 -12
View File
@@ -34,10 +34,10 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans, work)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dprc_aply
use psb_prec_mod, mld_protect_name => mld_dprec_aply
implicit none
@@ -74,7 +74,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
iwsz = max(1,4*psb_cd_get_local_cols(desc_data))
allocate(work_(iwsz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
call psb_errpush(4025,name,i_err=(/iwsz,0,0,0,0/),a_err='real(kind(1.d0))')
goto 9999
end if
@@ -85,14 +85,14 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
end if
if (size(prec%baseprecv) >1) then
if (debug) write(0,*) 'Into mlprc_aply',size(x),size(y)
call psb_mlprc_aply(done,prec%baseprecv,x,dzero,y,desc_data,trans_,work_,info)
call mld_mlprec_aply(done,prec%baseprecv,x,dzero,y,desc_data,trans_,work_,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_dmlprc_aply')
call psb_errpush(4010,name,a_err='mld_dmlprec_aply')
goto 9999
end if
else if (size(prec%baseprecv) == 1) then
call psb_baseprc_aply(done,prec%baseprecv(1),x,dzero,y,desc_data,trans_, work_,info)
call mld_baseprec_aply(done,prec%baseprecv(1),x,dzero,y,desc_data,trans_, work_,info)
else
write(0,*) 'Inconsistent preconditioner: size of baseprecv???'
endif
@@ -113,7 +113,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
end if
return
end subroutine psb_dprc_aply
end subroutine mld_dprec_aply
!!$
@@ -152,10 +152,10 @@ end subroutine psb_dprc_aply
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dprc_aply1(prec,x,desc_data,info,trans)
subroutine mld_dprec_aply1(prec,x,desc_data,info,trans)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dprc_aply1
use psb_prec_mod, mld_protect_name => mld_dprec_aply1
implicit none
@@ -187,11 +187,13 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans)
allocate(ww(size(x)),w1(size(x)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*size(x),0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
if (debug) write(0,*) 'Prc_aply1 Size(x) ',size(x), size(ww),size(w1)
call psb_dprc_aply(prec,x,ww,desc_data,info,trans_,work=w1)
call mld_dprec_aply(prec,x,ww,desc_data,info,trans_,work=w1)
if(info /=0) goto 9999
x(:) = ww(:)
deallocate(ww,W1)
@@ -207,4 +209,4 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans)
return
end if
return
end subroutine psb_dprc_aply1
end subroutine mld_dprec_aply1
mld_dslu_bld.f90
+5 -5
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dslu_bld(a,desc_a,p,info)
subroutine mld_dslu_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dslu_bld
use psb_prec_mod, mld_protect_name => mld_dslu_bld
implicit none
@@ -51,7 +51,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dslu_bld'
name='mld_dslu_bld'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
@@ -72,7 +72,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
call psb_barrier(ictxt)
endif
call psb_dslu_factor(a%m,nzt,&
call mld_dslu_factor(a%m,nzt,&
& a%aspk,a%ia2,a%ia1,p%iprcparm(slu_ptr_),info)
if (info /= 0) then
@@ -97,5 +97,5 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
end if
return
end subroutine psb_dslu_bld
end subroutine mld_dslu_bld
mld_dslud_bld.f90
+5 -5
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dsludist_bld(a,desc_a,p,info)
subroutine mld_dsludist_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dsludist_bld
use psb_prec_mod, mld_protect_name => mld_dsludist_bld
implicit none
@@ -52,7 +52,7 @@ subroutine psb_dsludist_bld(a,desc_a,p,info)
if (psb_get_errstatus().ne.0) return
info=0
name='psb_dslu_bld'
name='mld_dslu_bld'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
@@ -85,7 +85,7 @@ subroutine psb_dsludist_bld(a,desc_a,p,info)
npc = 1
call psb_loc_to_glob(a%ia1(1:nzt),desc_a,info,iact='I')
call psb_dsludist_factor(mglob,nrow,nzt,ifrst,&
call mld_dsludist_factor(mglob,nrow,nzt,ifrst,&
& a%aspk,a%ia2,a%ia1,p%iprcparm(slud_ptr_),&
& npr, npc, info)
if (info /= 0) then
@@ -107,5 +107,5 @@ subroutine psb_dsludist_bld(a,desc_a,p,info)
end if
return
end subroutine psb_dsludist_bld
end subroutine mld_dsludist_bld
mld_dsp_renum.f90
+4 -4
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info)
subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dsp_renum
use psb_prec_mod, mld_protect_name => mld_dsp_renum
implicit none
@@ -58,7 +58,7 @@ subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info)
if (psb_get_errstatus().ne.0) return
info=0
name='psb_dsp_renum'
name='mld_dsp_renum'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -298,4 +298,4 @@ contains
end subroutine gps_reduction
end subroutine psb_dsp_renum
end subroutine mld_dsp_renum
mld_dumf_bld.f90
+5 -5
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dumf_bld(a,desc_a,p,info)
subroutine mld_dumf_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_dumf_bld
use psb_prec_mod, mld_protect_name => mld_dumf_bld
implicit none
@@ -52,7 +52,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
character(len=20) :: name, ch_err
info=0
name='psb_dumf_bld'
name='mld_dumf_bld'
call psb_erractionsave(err_act)
ictxt = desc_A%matrix_data(psb_ctxt_)
@@ -75,7 +75,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
call psb_barrier(ictxt)
endif
call psb_dumf_factor(a%m,nzt,&
call mld_dumf_factor(a%m,nzt,&
& a%aspk,a%ia1,a%ia2,&
& p%iprcparm(umf_symptr_),p%iprcparm(umf_numptr_),info)
@@ -102,7 +102,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
end if
return
end subroutine psb_dumf_bld
end subroutine mld_dumf_bld
mld_slu_impl.c
+12 -12
View File
@@ -112,26 +112,26 @@ typedef struct {
#ifdef Add_
#define psb_dslu_factor_ psb_dslu_factor_
#define psb_dslu_solve_ psb_dslu_solve_
#define psb_dslu_free_ psb_dslu_free_
#define mld_dslu_factor_ mld_dslu_factor_
#define mld_dslu_solve_ mld_dslu_solve_
#define mld_dslu_free_ mld_dslu_free_
#endif
#ifdef AddDouble_
#define psb_dslu_factor_ psb_dslu_factor__
#define psb_dslu_solve_ psb_dslu_solve__
#define psb_dslu_free_ psb_dslu_free__
#define mld_dslu_factor_ mld_dslu_factor__
#define mld_dslu_solve_ mld_dslu_solve__
#define mld_dslu_free_ mld_dslu_free__
#endif
#ifdef NoChange
#define psb_dslu_factor_ psb_dslu_factor
#define psb_dslu_solve_ psb_dslu_solve
#define psb_dslu_free_ psb_dslu_free
#define mld_dslu_factor_ mld_dslu_factor
#define mld_dslu_solve_ mld_dslu_solve
#define mld_dslu_free_ mld_dslu_free
#endif
void
psb_dslu_factor_(int *n, int *nnz,
mld_dslu_factor_(int *n, int *nnz,
double *values, int *rowptr, int *colind,
#ifdef Have_SLU_
fptr *f_factors, /* a handle containing the address
@@ -255,7 +255,7 @@ psb_dslu_factor_(int *n, int *nnz,
void
psb_dslu_solve_(int *itrans, int *n, int *nrhs,
mld_dslu_solve_(int *itrans, int *n, int *nrhs,
double *b, int *ldb,
#ifdef Have_SLU_
fptr *f_factors, /* a handle containing the address
@@ -321,7 +321,7 @@ psb_dslu_solve_(int *itrans, int *n, int *nrhs,
void
psb_dslu_free_(
mld_dslu_free_(
#ifdef Have_SLU_
fptr *f_factors, /* a handle containing the address
pointing to the factored matrices */
mld_slud_impl.c
+12 -12
View File
@@ -112,26 +112,26 @@ typedef struct {
#ifdef Add_
#define psb_dsludist_factor_ psb_dsludist_factor_
#define psb_dsludist_solve_ psb_dsludist_solve_
#define psb_dsludist_free_ psb_dsludist_free_
#define mld_dsludist_factor_ mld_dsludist_factor_
#define mld_dsludist_solve_ mld_dsludist_solve_
#define mld_dsludist_free_ mld_dsludist_free_
#endif
#ifdef AddDouble_
#define psb_dsludist_factor_ psb_dsludist_factor__
#define psb_dsludist_solve_ psb_dsludist_solve__
#define psb_dsludist_free_ psb_dsludist_free__
#define mld_dsludist_factor_ mld_dsludist_factor__
#define mld_dsludist_solve_ mld_dsludist_solve__
#define mld_dsludist_free_ mld_dsludist_free__
#endif
#ifdef NoChange
#define psb_dsludist_factor_ psb_dsludist_factor
#define psb_dsludist_solve_ psb_dsludist_solve
#define psb_dsludist_free_ psb_dsludist_free
#define mld_dsludist_factor_ mld_dsludist_factor
#define mld_dsludist_solve_ mld_dsludist_solve
#define mld_dsludist_free_ mld_dsludist_free
#endif
void
psb_dsludist_factor_(int *n, int *nl, int *nnzl, int *ffstr,
mld_dsludist_factor_(int *n, int *nl, int *nnzl, int *ffstr,
double *values, int *rowptr, int *colind,
#ifdef Have_SLUDist_
fptr *f_factors, /* a handle containing the address
@@ -239,7 +239,7 @@ psb_dsludist_factor_(int *n, int *nl, int *nnzl, int *ffstr,
void
psb_dsludist_solve_(int *itrans, int *n, int *nrhs,
mld_dsludist_solve_(int *itrans, int *n, int *nrhs,
double *b, int *ldb,
#ifdef Have_SLUDist_
fptr *f_factors, /* a handle containing the address
@@ -322,7 +322,7 @@ psb_dsludist_solve_(int *itrans, int *n, int *nrhs,
void
psb_dsludist_free_(
mld_dsludist_free_(
#ifdef Have_SLUDist_
fptr *f_factors, /* a handle containing the address
pointing to the factored matrices */
mld_umf_impl.c
+12 -12
View File
@@ -73,19 +73,19 @@ Availability:
#ifdef Add_
#define psb_dumf_factor_ psb_dumf_factor_
#define psb_dumf_solve_ psb_dumf_solve_
#define psb_dumf_free_ psb_dumf_free_
#define mld_dumf_factor_ mld_dumf_factor_
#define mld_dumf_solve_ mld_dumf_solve_
#define mld_dumf_free_ mld_dumf_free_
#endif
#ifdef AddDouble_
#define psb_dumf_factor_ psb_dumf_factor__
#define psb_dumf_solve_ psb_dumf_solve__
#define psb_dumf_free_ psb_dumf_free__
#define mld_dumf_factor_ mld_dumf_factor__
#define mld_dumf_solve_ mld_dumf_solve__
#define mld_dumf_free_ mld_dumf_free__
#endif
#ifdef NoChange
#define psb_dumf_factor_ psb_dumf_factor
#define psb_dumf_solve_ psb_dumf_solve
#define psb_dumf_free_ psb_dumf_free
#define mld_dumf_factor_ mld_dumf_factor
#define mld_dumf_solve_ mld_dumf_solve
#define mld_dumf_free_ mld_dumf_free
#endif
@@ -101,7 +101,7 @@ typedef int fptr; /* 32-bit by default */
#endif
void
psb_dumf_factor_(int *n, int *nnz,
mld_dumf_factor_(int *n, int *nnz,
double *values, int *rowind, int *colptr,
#ifdef Have_UMF_
fptr *symptr,
@@ -163,7 +163,7 @@ psb_dumf_factor_(int *n, int *nnz,
void
psb_dumf_solve_(int *itrans, int *n,
mld_dumf_solve_(int *itrans, int *n,
double *x, double *b, int *ldb,
#ifdef Have_UMF_
fptr *numptr,
@@ -204,7 +204,7 @@ psb_dumf_solve_(int *itrans, int *n,
void
psb_dumf_free_(
mld_dumf_free_(
#ifdef Have_UMF_
fptr *symptr,
fptr *numptr,
mld_zaggrmap_bld.f90
+13 -10
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zgenaggrmap
use psb_prec_mod, mld_protect_name => mld_zaggrmap_bld
implicit none
integer, intent(in) :: aggr_type
@@ -57,7 +57,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_zgenaggrmap'
name = 'mld_zaggrmap_bld'
call psb_erractionsave(err_act)
!
! Note. At the time being we are ignoring aggr_type
@@ -72,8 +72,9 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info)
if(info.ne.0) then
info=4000
call psb_errpush(info,name,a_err=ch_err)
info=4025
call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
@@ -148,8 +149,9 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
!
allocate(ils(naggr+10),stat=info)
if(info.ne.0) then
info=4000
call psb_errpush(info,name)
info=4025
call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
@@ -270,8 +272,9 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
allocate(nlaggr(np),stat=info)
if (info/=0) then
info=4000
call psb_errpush(info,name)
info=4025
call psb_errpush(info,name,i_err=(/np,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
@@ -290,4 +293,4 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
end if
return
end subroutine psb_zgenaggrmap
end subroutine mld_zaggrmap_bld
mld_zaggrmat_asb.F90
+17 -9
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zbldaggrmat(a,desc_a,ac,desc_ac,p,info)
subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zbldaggrmat
use psb_prec_mod, mld_protect_name => mld_zaggrmat_asb
implicit none
@@ -48,14 +48,16 @@ subroutine psb_zbldaggrmat(a,desc_a,ac,desc_ac,p,info)
integer, intent(out) :: info
logical, parameter :: aggr_dump=.false.
integer ::ictxt,np,me, err_act
integer ::ictxt,np,me, err_act,icomm
character(len=20) :: name, ch_err
name='psb_zbldaggrmat'
name='mld_zaggrmat_asb'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
icomm = psb_cd_get_mpic(desc_a)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
@@ -133,9 +135,10 @@ contains
naggr = p%nlaggr(me+1)
ntaggr = sum(p%nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
@@ -350,7 +353,9 @@ contains
allocate(nzbr(np), idisp(np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
goto 9999
end if
@@ -387,7 +392,9 @@ contains
!
allocate(p%dorig(nrow),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -893,6 +900,7 @@ contains
goto 9999
end if
call psb_get_mpicomm(ictxt,icomm)
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@@ -956,4 +964,4 @@ contains
end subroutine psb_zbldaggrmat
end subroutine mld_zaggrmat_asb
mld_zasmat_bld.f90
+6 -7
View File
@@ -51,10 +51,10 @@
!* *
!* *
!*****************************************************************************
Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zasmatbld
use psb_prec_mod, mld_protect_name => mld_zasmat_bld
Implicit None
@@ -79,15 +79,13 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Logical,Parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err
name='psb_zasmatbld'
name='mld_zasmat_bld'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
If(debug) Write(0,*)'IN DASMATBLD ', upd
ictxt = psb_cd_get_context(desc_data)
icomm = psb_cd_get_mpic(desc_data)
ictxt=desc_data%matrix_data(psb_ctxt_)
Call psb_info(ictxt, me, np)
tot_recv=0
@@ -170,6 +168,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
return
endif
call psb_get_mpicomm(ictxt,icomm)
If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr
t1 = psb_wtime()
@@ -235,5 +234,5 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if
Return
End Subroutine psb_zasmatbld
End Subroutine mld_zasmat_bld
mld_zbaseprec_aply.f90
+9 -9
View File
@@ -34,13 +34,13 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
!
! Compute Y <- beta*Y + alpha*K^-1 X
! where K is a a basic preconditioner stored in prec
!
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zbaseprc_aply
use psb_prec_mod, mld_protect_name => mld_zbaseprec_aply
implicit none
@@ -61,7 +61,7 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err
name='psb_zbaseprc_aply'
name='mld_zbaseprec_aply'
info = 0
call psb_erractionsave(err_act)
@@ -114,10 +114,10 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case(bjac_)
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then
info=4010
ch_err='psb_bjac_aply'
ch_err='mld_bjac_aply'
goto 9999
end if
@@ -125,7 +125,7 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if (prec%iprcparm(n_ovr_)==0) then
! shortcut: this fixes performance for RAS(0) == BJA
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then
info=4010
ch_err='psb_bjacaply'
@@ -197,10 +197,10 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
endif
call psb_bjac_aply(zone,prec,tx,zzero,ty,prec%desc_data,trans,aux,info)
call mld_bjac_aply(zone,prec,tx,zzero,ty,prec%desc_data,trans,aux,info)
if(info.ne.0) then
info=4010
ch_err='psb_bjac_aply'
ch_err='mld_bjac_aply'
goto 9999
end if
@@ -263,5 +263,5 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
return
end subroutine psb_zbaseprc_aply
end subroutine mld_zbaseprec_aply
mld_zbaseprec_bld.f90
+10 -10
View File
@@ -34,10 +34,10 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zbaseprc_bld
use psb_prec_mod, mld_protect_name => mld_zbaseprc_bld
Implicit None
@@ -63,7 +63,7 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
info=0
err=0
call psb_erractionsave(err_act)
name = 'psb_zbaseprc_bld'
name = 'mld_zbaseprc_bld'
if (debug) write(0,*) 'Entering baseprc_bld'
info = 0
@@ -110,11 +110,11 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
case (diag_)
call psb_diagsc_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_diagsc_bld'
call mld_diag_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of mld_diag_bld'
if(info /= 0) then
info=4010
ch_err='psb_diagsc_bld'
ch_err='mld_diag_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -137,13 +137,13 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
p%iprcparm(jac_sweeps_) = 1
end if
if (debug) write(0,*)me, ': Calling PSB_BJAC_BLD'
if (debug) write(0,*)me, ': Calling mld_bjac_bld'
if (debug) call psb_barrier(ictxt)
call psb_bjac_bld(a,desc_a,p,iupd,info)
call mld_bjac_bld(a,desc_a,p,iupd,info)
if(info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_bjac_bld')
call psb_errpush(info,name,a_err='mld_bjac_bld')
goto 9999
end if
@@ -170,5 +170,5 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
end if
return
end subroutine psb_zbaseprc_bld
end subroutine mld_zbaseprc_bld
mld_zbjac_aply.f90
+24 -18
View File
@@ -34,7 +34,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
!
! Compute Y <- beta*Y + alpha*K^-1 X
! where K is a a Block Jacobi preconditioner stored in prec
@@ -43,7 +43,7 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
!
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zbjac_aply
use psb_prec_mod, mld_protect_name => mld_zbjac_aply
implicit none
@@ -64,7 +64,7 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err
name='psb_zbjac_aply'
name='mld_zbjac_aply'
info = 0
call psb_erractionsave(err_act)
@@ -90,7 +90,9 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
else
allocate(aux(4*n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
& a_err='complex(kind(1.d0))')
goto 9999
end if
@@ -98,7 +100,9 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
else
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
& a_err='complex(kind(1.d0))')
goto 9999
end if
endif
@@ -136,11 +140,11 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
select case(toupper(trans))
case('N')
call psb_zslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
call mld_zslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
case('T')
call psb_zslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
call mld_zslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
case('C')
call psb_zslu_solve(2,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
call mld_zslu_solve(2,n_row,1,ww,n_row,prec%iprcparm(slu_ptr_),info)
end select
if(info /=0) goto 9999
@@ -153,11 +157,11 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
select case(toupper(trans))
case('N')
call psb_zsludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
call mld_zsludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
case('T')
call psb_zsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
call mld_zsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
case('C')
call psb_zsludist_solve(2,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
call mld_zsludist_solve(2,n_row,1,ww,n_row,prec%iprcparm(slud_ptr_),info)
end select
if(info /=0) goto 9999
@@ -168,11 +172,11 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
select case(toupper(trans))
case('N')
call psb_zumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
call mld_zumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
case('T')
call psb_zumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
call mld_zumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
case('C')
call psb_zumf_solve(2,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
call mld_zumf_solve(2,n_row,ww,x,n_row,prec%iprcparm(umf_numptr_),info)
end select
if(info /=0) goto 9999
@@ -195,7 +199,9 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
allocate(tx(n_col),ty(n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*n_col,0,0,0,0/),&
& a_err='complex(kind(1.d0))')
goto 9999
end if
@@ -231,7 +237,7 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
& prec%desc_data,info,work=aux)
if(info /=0) goto 9999
call psb_zslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(slu_ptr_),info)
call mld_zslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(slu_ptr_),info)
if(info /=0) goto 9999
tx(1:n_row) = ty(1:n_row)
end do
@@ -243,7 +249,7 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
& prec%desc_data,info,work=aux)
if(info /=0) goto 9999
call psb_zumf_solve(0,n_row,ww,ty,n_row,&
call mld_zumf_solve(0,n_row,ww,ty,n_row,&
& prec%iprcparm(umf_numptr_),info)
if(info /=0) goto 9999
tx(1:n_row) = ww(1:n_row)
@@ -287,5 +293,5 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
return
end subroutine psb_zbjac_aply
end subroutine mld_zbjac_aply
mld_zbjac_bld.f90
+19 -19
View File
@@ -49,9 +49,9 @@
!* *
!* *
!*****************************************************************************
subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zbjac_bld
use psb_prec_mod, mld_protect_name => mld_zbjac_bld
implicit none
!
@@ -78,7 +78,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
if(psb_get_errstatus().ne.0) return
info=0
name='psb_zbjac_bld'
name='mld_zbjac_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -107,18 +107,18 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
t1= psb_wtime()
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if(debug) write(0,*)me,': calling mld_asmat_bld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if (debug) call psb_barrier(ictxt)
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
call mld_asmat_bld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=coofmt)
if(info/=0) then
call psb_errpush(4010,name,a_err='psb_asmatbld')
call psb_errpush(4010,name,a_err='mld_asmat_bld')
goto 9999
end if
t2= psb_wtime()
if (debug) write(0,*)me,': out of psb_asmatbld'
if (debug) write(0,*)me,': out of mld_asmat_bld'
if (debug) call psb_barrier(ictxt)
@@ -131,10 +131,10 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
! Done inside sp_renum.
!
call psb_sp_renum(a,desc_a,blck,p,atmp,info)
call mld_sp_renum(a,desc_a,blck,p,atmp,info)
if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_renum')
call psb_errpush(4010,name,a_err='mld_sp_renum')
goto 9999
end if
@@ -182,10 +182,10 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_ilu_bld(atmp,p%desc_data,p,upd,info)
call mld_ilu_bld(atmp,p%desc_data,p,upd,info)
if (info/=0) then
call psb_errpush(4010,name,a_err='psb_ilu_bld')
call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999
end if
@@ -213,7 +213,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_slu_bld(atmp,p%desc_data,p,info)
call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='slu_bld')
goto 9999
@@ -227,7 +227,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_umf_bld(atmp,p%desc_data,p,info)
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if (info /= 0) then
call psb_errpush(4010,name,a_err='umf_bld')
@@ -305,10 +305,10 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_ilu_bld(a,desc_a,p,upd,info,blck=blck)
call mld_ilu_bld(a,desc_a,p,upd,info,blck=blck)
if(info/=0) then
call psb_errpush(4010,name,a_err='psb_ilu_bld')
call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999
end if
@@ -366,7 +366,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
endif
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call psb_slu_bld(atmp,p%desc_data,p,info)
if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='slu_bld')
goto 9999
@@ -419,7 +419,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
!!$ nztmp = psb_sp_get_nnzeros(atmp)
!!$ call psb_loc_to_glob(atmp%ia2(1:nztmp),p%desc_data,info,iact='I')
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call psb_sludist_bld(atmp,p%desc_data,p,info)
if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='slu_bld')
goto 9999
@@ -477,7 +477,7 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
call psb_umf_bld(atmp,p%desc_data,p,info)
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if (info /= 0) then
call psb_errpush(4010,name,a_err='umf_bld')
@@ -532,6 +532,6 @@ subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
return
end subroutine psb_zbjac_bld
end subroutine mld_zbjac_bld
mld_zdiagsc_bld.f90
+7 -6
View File
@@ -34,10 +34,10 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
subroutine mld_zdiag_bld(a,desc_a,p,upd,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zdiagsc_bld
use psb_prec_mod, mld_protect_name => mld_zdiag_bld
Implicit None
@@ -63,7 +63,7 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
info=0
err=0
call psb_erractionsave(err_act)
name = 'psb_zdiagsc_bld'
name = 'mld_zdiag_bld'
if (debug) write(0,*) 'Entering diagsc_bld'
info = 0
@@ -109,8 +109,9 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
if (a%pl(1) /= 0) then
allocate(work(n_row),stat=info)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
info=4025
call psb_errpush(info,name,i_err=(/n_row,0,0,0,0/),&
& a_err='complex(kind(1.d0))')
goto 9999
end if
call psb_gelp('n',a%pl,p%d,desc_a,info)
@@ -161,5 +162,5 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
end if
return
end subroutine psb_zdiagsc_bld
end subroutine mld_zdiag_bld
mld_zilu_bld.f90
+6 -6
View File
@@ -49,9 +49,9 @@
!* *
!* *
!*****************************************************************************
subroutine psb_zilu_bld(a,desc_a,p,upd,info,blck)
subroutine mld_zilu_bld(a,desc_a,p,upd,info,blck)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zilu_bld
use psb_prec_mod, mld_protect_name => mld_zilu_bld
implicit none
!
@@ -76,7 +76,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info,blck)
if(psb_get_errstatus().ne.0) return
info=0
name='psb_zilu_bld'
name='mld_zilu_bld'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -148,10 +148,10 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info,blck)
! Ok, factor the matrix.
!
t5 = psb_wtime()
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
call mld_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
if(info/=0) then
info=4010
ch_err='psb_ilu_fct'
ch_err='mld_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -205,6 +205,6 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info,blck)
return
end subroutine psb_zilu_bld
end subroutine mld_zilu_bld
mld_zilu_fct.f90
+8 -8
View File
@@ -34,7 +34,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zilu_fct(a,l,u,d,info,blck)
subroutine mld_zilu_fct(a,l,u,d,info,blck)
!
! This routine copies and factors "on the fly" from A and BLCK
@@ -55,7 +55,7 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck)
type(psb_zspmat_type), pointer :: blck_
character(len=20) :: name, ch_err
name='psb_zilu_fct'
name='mld_zilu_fct'
info = 0
call psb_erractionsave(err_act)
! .. Executable Statements ..
@@ -82,11 +82,11 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck)
blck_%m=0
endif
call psb_zilu_fctint(m,a%m,a,blck_%m,blck_,&
call mld_zilu_fctint(m,a%m,a,blck_%m,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
if(info.ne.0) then
info=4010
ch_err='psb_zilu_fctint'
ch_err='mld_zilu_fctint'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -126,7 +126,7 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck)
return
contains
subroutine psb_zilu_fctint(m,ma,a,mb,b,&
subroutine mld_zilu_fctint(m,ma,a,mb,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info)
implicit none
@@ -143,7 +143,7 @@ contains
integer :: int_err(5)
character(len=20) :: name, ch_err
name='psb_zilu_fctint'
name='mld_zilu_fctint'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@@ -464,5 +464,5 @@ contains
return
end if
return
end subroutine psb_zilu_fctint
end subroutine psb_zilu_fct
end subroutine mld_zilu_fctint
end subroutine mld_zilu_fct
mld_zmlprec_aply.f90
+48 -34
View File
@@ -34,7 +34,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
!
! Compute Y <- beta*Y + alpha*K^-1 X
! where K is a multilevel preconditioner stored in baseprecv
@@ -55,7 +55,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! as many subdomains as there are processes (except for the coarsest level where
! we might have a replicated index space). Thus the sum apparently disappears
! from our code, but only apparently, because it is implicit in the call
! to psb_baseprc_aply.
! to mld_baseprec_aply.
!
! A bit of description of the baseprecv(:) data structure:
! 1. Number of levels = NLEV = size(baseprecv(:))
@@ -84,7 +84,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
!
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zmlprc_aply
use psb_prec_mod, mld_protect_name => mld_zmlprec_aply
implicit none
@@ -112,7 +112,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end type psb_mlprec_wrk_type
type(psb_mlprec_wrk_type), allocatable :: mlprec_wrk(:)
name='psb_zmlprc_aply'
name='mld_zmlprec_aply'
info = 0
call psb_erractionsave(err_act)
@@ -155,10 +155,17 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! 1..NLEV <=> (j) <-> 0
call psb_baseprc_aply(alpha,baseprecv(1),x,beta,y,&
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info)
if(info /=0) goto 9999
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)))
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/size(x)+size(y),0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(1)%x2l(:) = x(:)
@@ -171,7 +178,9 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev)%tx(max(n_row,n_col)),&
& mlprec_wrk(ilev)%ty(max(n_row,n_col)), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -188,8 +197,6 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
!
! Smoothed aggregation
!
call psb_halo(mlprec_wrk(ilev-1)%x2l,baseprecv(ilev-1)%base_desc,&
& info,work=work)
if(info /=0) goto 9999
@@ -216,7 +223,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',icm
endif
call psb_baseprc_aply(zone,baseprecv(ilev),&
call mld_baseprec_aply(zone,baseprecv(ilev),&
& mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%desc_data, 'N',work,info)
@@ -314,7 +321,9 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -367,7 +376,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
enddo
call psb_baseprc_aply(zone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
call mld_baseprec_aply(zone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& zzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info)
if(info /=0) goto 9999
@@ -399,7 +408,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if(info /=0) goto 9999
@@ -437,14 +446,16 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(1)%y2l(:) = zzero
mlprec_wrk(1)%x2l(:) = x
call psb_baseprc_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
call mld_baseprec_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
& zzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,&
& trans,work,info)
@@ -467,10 +478,10 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
@@ -510,7 +521,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
endif
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
if(info /=0) goto 9999
@@ -583,22 +594,24 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(1)%x2l(:) = zzero
mlprec_wrk(1)%y2l(:) = zzero
mlprec_wrk(1)%tx(:) = zzero
mlprec_wrk(1)%ty(:) = zzero
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
call psb_baseprc_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
call mld_baseprec_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
& zzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,&
& trans,work,info)
@@ -621,18 +634,19 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
allocate(mlprec_wrk(ilev)%ty(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(kind(1.d0))')
goto 9999
end if
mlprec_wrk(ilev)%x2l(:) = zzero
mlprec_wrk(ilev)%y2l(:) = zzero
mlprec_wrk(ilev)%tx(:) = zzero
mlprec_wrk(ilev)%ty(:) = zzero
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
if (ismth /= no_smth_) then
!
!Smoothed Aggregation
@@ -667,7 +681,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& baseprecv(ilev)%base_desc,info)
if(info /=0) goto 9999
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
if(info /=0) goto 9999
@@ -708,7 +722,7 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_baseprc_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if(info /=0) goto 9999
@@ -768,5 +782,5 @@ subroutine psb_zmlprc_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
!!$ end do
!!$ end subroutine mlprec_wrk_free
end subroutine psb_zmlprc_aply
end subroutine mld_zmlprec_aply
mld_zmlprec_bld.f90
+8 -8
View File
@@ -34,10 +34,10 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zmlprc_bld(a,desc_a,p,info)
subroutine mld_zmlprec_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zmlprc_bld
use psb_prec_mod, mld_protect_name => mld_zmlprec_bld
implicit none
@@ -95,7 +95,7 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
! Currently this is ignored by gen_aggrmap, but it could be
! changed in the future. Need to package nlaggr & mlia in a
! private data structure?
call psb_genaggrmap(p%iprcparm(aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info)
call mld_aggrmap_bld(p%iprcparm(aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then
info=4010
ch_err='psb_gen_aggrmap'
@@ -106,7 +106,7 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
call psb_nullify_desc(desc_ac)
call psb_bldaggrmat(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then
info=4010
ch_err='psb_bld_aggrmat'
@@ -117,11 +117,11 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
call psb_baseprc_bld(ac,desc_ac,p,info)
call mld_baseprc_bld(ac,desc_ac,p,info)
if (debug) write(0,*) 'Out from baseprcbld',info
if(info /= 0) then
info=4010
ch_err='psb_baseprc_bld'
ch_err='mld_baseprc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@@ -129,7 +129,7 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
!
! We have used a separate ac because:
! 1. We want to reuse the same routines psb_ilu_bld etc.
! 1. We want to reuse the same routines mld_ilu_bld etc.
! 2. We do NOT want to pass an argument twice to them
! p%av(ac_) and p, as this would violate the Fortran standard
! Hence a separate AC and a TRANSFER function at the end.
@@ -157,4 +157,4 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
end if
Return
end subroutine psb_zmlprc_bld
end subroutine mld_zmlprec_bld
mld_zprec_aply.f90
+17 -13
View File
@@ -34,10 +34,10 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans, work)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zprc_aply
use psb_prec_mod, mld_protect_name => mld_zprec_aply
implicit none
@@ -55,7 +55,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name
name='psb_zprc_aply'
name='mld_zprec_aply'
info = 0
call psb_erractionsave(err_act)
@@ -74,7 +74,9 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
iwsz = max(1,4*psb_cd_get_local_cols(desc_data))
allocate(work_(iwsz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/iwsz,0,0,0,0/),&
& a_err='complex(kind(1.d0))')
goto 9999
end if
@@ -85,14 +87,14 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
end if
if (size(prec%baseprecv) >1) then
if (debug) write(0,*) 'Into mlprc_aply',size(x),size(y)
call psb_mlprc_aply(zone,prec%baseprecv,x,zzero,y,desc_data,trans_,work_,info)
call mld_mlprec_aply(zone,prec%baseprecv,x,zzero,y,desc_data,trans_,work_,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_zmlprc_aply')
call psb_errpush(4010,name,a_err='mld_zmlprec_aply')
goto 9999
end if
else if (size(prec%baseprecv) == 1) then
call psb_baseprc_aply(zone,prec%baseprecv(1),x,zzero,y,desc_data,trans_, work_,info)
call mld_baseprec_aply(zone,prec%baseprecv(1),x,zzero,y,desc_data,trans_, work_,info)
else
write(0,*) 'Inconsistent preconditioner: size of baseprecv???'
endif
@@ -113,7 +115,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
end if
return
end subroutine psb_zprc_aply
end subroutine mld_zprec_aply
!!$
@@ -152,9 +154,9 @@ end subroutine psb_zprc_aply
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zprc_aply1(prec,x,desc_data,info,trans)
subroutine mld_zprec_aply1(prec,x,desc_data,info,trans)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zprc_aply1
use psb_prec_mod, mld_protect_name => mld_zprec_aply1
implicit none
@@ -185,11 +187,13 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans)
allocate(ww(size(x)),w1(size(x)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
info=4025
call psb_errpush(info,name,i_err=(/2*size(x),0,0,0,0/),&
& a_err='complex(kind(1.d0))')
goto 9999
end if
if (debug) write(0,*) 'Prc_aply1 Size(x) ',size(x), size(ww),size(w1)
call psb_zprc_aply(prec,x,ww,desc_data,info,trans_,work=w1)
call mld_zprec_aply(prec,x,ww,desc_data,info,trans_,work=w1)
if(info /=0) goto 9999
x(:) = ww(:)
deallocate(ww,W1)
@@ -205,4 +209,4 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans)
return
end if
return
end subroutine psb_zprc_aply1
end subroutine mld_zprec_aply1
mld_zslu_bld.f90
+5 -5
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zslu_bld(a,desc_a,p,info)
subroutine mld_zslu_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zslu_bld
use psb_prec_mod, mld_protect_name => mld_zslu_bld
implicit none
@@ -51,7 +51,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
if(psb_get_errstatus().ne.0) return
info=0
name='psb_zslu_bld'
name='mld_zslu_bld'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
@@ -72,7 +72,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
call psb_barrier(ictxt)
endif
call psb_zslu_factor(a%m,nzt,&
call mld_zslu_factor(a%m,nzt,&
& a%aspk,a%ia2,a%ia1,p%iprcparm(slu_ptr_),info)
if (info /= 0) then
@@ -97,5 +97,5 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
end if
return
end subroutine psb_zslu_bld
end subroutine mld_zslu_bld
mld_zslu_impl.c
+12 -12
View File
@@ -111,26 +111,26 @@ typedef struct {
#ifdef Add_
#define psb_zslu_factor_ psb_zslu_factor_
#define psb_zslu_solve_ psb_zslu_solve_
#define psb_zslu_free_ psb_zslu_free_
#define mld_zslu_factor_ mld_zslu_factor_
#define mld_zslu_solve_ mld_zslu_solve_
#define mld_zslu_free_ mld_zslu_free_
#endif
#ifdef AddDouble_
#define psb_zslu_factor_ psb_zslu_factor__
#define psb_zslu_solve_ psb_zslu_solve__
#define psb_zslu_free_ psb_zslu_free__
#define mld_zslu_factor_ mld_zslu_factor__
#define mld_zslu_solve_ mld_zslu_solve__
#define mld_zslu_free_ mld_zslu_free__
#endif
#ifdef NoChange
#define psb_zslu_factor_ psb_zslu_factor
#define psb_zslu_solve_ psb_zslu_solve
#define psb_zslu_free_ psb_zslu_free
#define mld_zslu_factor_ mld_zslu_factor
#define mld_zslu_solve_ mld_zslu_solve
#define mld_zslu_free_ mld_zslu_free
#endif
void
psb_zslu_factor_(int *n, int *nnz,
mld_zslu_factor_(int *n, int *nnz,
#ifdef Have_SLU_
doublecomplex *values, int *colind, int *rowptr,
fptr *f_factors, /* a handle containing the address
@@ -255,7 +255,7 @@ psb_zslu_factor_(int *n, int *nnz,
void
psb_zslu_solve_(int *itrans, int *n, int *nrhs,
mld_zslu_solve_(int *itrans, int *n, int *nrhs,
#ifdef Have_SLU_
doublecomplex *b, int *ldb,
fptr *f_factors, /* a handle containing the address
@@ -327,7 +327,7 @@ psb_zslu_solve_(int *itrans, int *n, int *nrhs,
void
psb_zslu_free_(
mld_zslu_free_(
#ifdef Have_SLU_
fptr *f_factors, /* a handle containing the address
pointing to the factored matrices */
mld_zslud_bld.f90
+5 -5
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zsludist_bld(a,desc_a,p,info)
subroutine mld_zsludist_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zsludist_bld
use psb_prec_mod, mld_protect_name => mld_zsludist_bld
implicit none
@@ -52,7 +52,7 @@ subroutine psb_zsludist_bld(a,desc_a,p,info)
if(psb_get_errstatus().ne.0) return
info=0
name='psb_zslu_bld'
name='mld_zslu_bld'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
@@ -96,7 +96,7 @@ subroutine psb_zsludist_bld(a,desc_a,p,info)
ip = ip - 1
end do
!!$ write(0,*) 'Process grid : ',npr,npc
call psb_zsludist_factor(mglob,nrow,nzt,ifrst,&
call mld_zsludist_factor(mglob,nrow,nzt,ifrst,&
& a%aspk,a%ia2,a%ia1,p%iprcparm(slud_ptr_),&
& npr, npc, info)
if (info /= 0) then
@@ -118,5 +118,5 @@ subroutine psb_zsludist_bld(a,desc_a,p,info)
end if
return
end subroutine psb_zsludist_bld
end subroutine mld_zsludist_bld
mld_zslud_impl.c
+12 -12
View File
@@ -112,26 +112,26 @@ typedef struct {
#ifdef Add_
#define psb_zsludist_factor_ psb_zsludist_factor_
#define psb_zsludist_solve_ psb_zsludist_solve_
#define psb_zsludist_free_ psb_zsludist_free_
#define mld_zsludist_factor_ mld_zsludist_factor_
#define mld_zsludist_solve_ mld_zsludist_solve_
#define mld_zsludist_free_ mld_zsludist_free_
#endif
#ifdef AddDouble_
#define psb_zsludist_factor_ psb_zsludist_factor__
#define psb_zsludist_solve_ psb_zsludist_solve__
#define psb_zsludist_free_ psb_zsludist_free__
#define mld_zsludist_factor_ mld_zsludist_factor__
#define mld_zsludist_solve_ mld_zsludist_solve__
#define mld_zsludist_free_ mld_zsludist_free__
#endif
#ifdef NoChange
#define psb_zsludist_factor_ psb_zsludist_factor
#define psb_zsludist_solve_ psb_zsludist_solve
#define psb_zsludist_free_ psb_zsludist_free
#define mld_zsludist_factor_ mld_zsludist_factor
#define mld_zsludist_solve_ mld_zsludist_solve
#define mld_zsludist_free_ mld_zsludist_free
#endif
void
psb_zsludist_factor_(int *n, int *nl, int *nnzl, int *ffstr,
mld_zsludist_factor_(int *n, int *nl, int *nnzl, int *ffstr,
#ifdef Have_SLUDist_
doublecomplex *values, int *rowptr, int *colind,
fptr *f_factors, /* a handle containing the address
@@ -239,7 +239,7 @@ psb_zsludist_factor_(int *n, int *nl, int *nnzl, int *ffstr,
void
psb_zsludist_solve_(int *itrans, int *n, int *nrhs,
mld_zsludist_solve_(int *itrans, int *n, int *nrhs,
#ifdef Have_SLUDist_
doublecomplex *b, int *ldb,
fptr *f_factors, /* a handle containing the address
@@ -323,7 +323,7 @@ psb_zsludist_solve_(int *itrans, int *n, int *nrhs,
void
psb_zsludist_free_(
mld_zsludist_free_(
#ifdef Have_SLUDist_
fptr *f_factors, /* a handle containing the address
pointing to the factored matrices */
mld_zsp_renum.f90
+4 -4
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info)
subroutine mld_zsp_renum(a,desc_a,blck,p,atmp,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zsp_renum
use psb_prec_mod, mld_protect_name => mld_zsp_renum
implicit none
@@ -58,7 +58,7 @@ subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info)
if (psb_get_errstatus().ne.0) return
info=0
name='psb_zsp_renum'
name='mld_zsp_renum'
call psb_erractionsave(err_act)
ictxt=psb_cd_get_context(desc_a)
@@ -455,4 +455,4 @@ contains
end subroutine gps_reduction
end subroutine psb_zsp_renum
end subroutine mld_zsp_renum
mld_zumf_bld.f90
+5 -5
View File
@@ -34,9 +34,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zumf_bld(a,desc_a,p,info)
subroutine mld_zumf_bld(a,desc_a,p,info)
use psb_base_mod
use psb_prec_mod, mld_protect_name => psb_zumf_bld
use psb_prec_mod, mld_protect_name => mld_zumf_bld
implicit none
@@ -52,7 +52,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
character(len=20) :: name, ch_err
info=0
name='psb_zumf_bld'
name='mld_zumf_bld'
call psb_erractionsave(err_act)
ictxt = desc_A%matrix_data(psb_ctxt_)
@@ -75,7 +75,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
call psb_barrier(ictxt)
endif
call psb_zumf_factor(a%m,nzt,&
call mld_zumf_factor(a%m,nzt,&
& a%aspk,a%ia1,a%ia2,&
& p%iprcparm(umf_symptr_),p%iprcparm(umf_numptr_),info)
@@ -102,7 +102,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
end if
return
end subroutine psb_zumf_bld
end subroutine mld_zumf_bld
mld_zumf_impl.c
+12 -12
View File
@@ -72,19 +72,19 @@ Availability:
#ifdef Add_
#define psb_zumf_factor_ psb_zumf_factor_
#define psb_zumf_solve_ psb_zumf_solve_
#define psb_zumf_free_ psb_zumf_free_
#define mld_zumf_factor_ mld_zumf_factor_
#define mld_zumf_solve_ mld_zumf_solve_
#define mld_zumf_free_ mld_zumf_free_
#endif
#ifdef AddDouble_
#define psb_zumf_factor_ psb_zumf_factor__
#define psb_zumf_solve_ psb_zumf_solve__
#define psb_zumf_free_ psb_zumf_free__
#define mld_zumf_factor_ mld_zumf_factor__
#define mld_zumf_solve_ mld_zumf_solve__
#define mld_zumf_free_ mld_zumf_free__
#endif
#ifdef NoChange
#define psb_zumf_factor_ psb_zumf_factor
#define psb_zumf_solve_ psb_zumf_solve
#define psb_zumf_free_ psb_zumf_free
#define mld_zumf_factor_ mld_zumf_factor
#define mld_zumf_solve_ mld_zumf_solve
#define mld_zumf_free_ mld_zumf_free
#endif
@@ -100,7 +100,7 @@ typedef int fptr; /* 32-bit by default */
#endif
void
psb_zumf_factor_(int *n, int *nnz,
mld_zumf_factor_(int *n, int *nnz,
double *values, int *rowind, int *colptr,
#ifdef Have_UMF_
fptr *symptr,
@@ -162,7 +162,7 @@ psb_zumf_factor_(int *n, int *nnz,
void
psb_zumf_solve_(int *itrans, int *n,
mld_zumf_solve_(int *itrans, int *n,
double *x, double *b, int *ldb,
#ifdef Have_UMF_
fptr *numptr,
@@ -203,7 +203,7 @@ psb_zumf_solve_(int *itrans, int *n,
void
psb_zumf_free_(
mld_zumf_free_(
#ifdef Have_UMF_
fptr *symptr,
fptr *numptr,