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

Merge MLD stuf. Phase 2.

Browse Source
stopcriterion
Salvatore Filippone 18 years ago
parent 6fcab933e8
commit 4158c73b0d
40 changed files with 499 additions and 427 deletions
Show Stats Download Patch File Download Diff File

29
mld_daggrmap_bld.f90
Unescape Escape 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

27
mld_daggrmat_asb.F90
Unescape Escape 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

8
mld_dasmat_bld.f90
Unescape Escape 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

29
mld_dbaseprec_aply.f90
Unescape Escape 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

20
mld_dbaseprec_bld.f90
Unescape Escape 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

36
mld_dbjac_aply.f90
Unescape Escape 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

38
mld_dbjac_bld.f90
Unescape Escape 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

17
mld_ddiagsc_bld.f90
Unescape Escape 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

12
mld_dilu_bld.f90
Unescape Escape 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

16
mld_dilu_fct.f90
Unescape Escape 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

83
mld_dmlprec_aply.f90
Unescape Escape 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

16
mld_dmlprec_bld.f90
Unescape Escape 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

26
mld_dprec_aply.f90
Unescape Escape 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

10
mld_dslu_bld.f90
Unescape Escape 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

10
mld_dslud_bld.f90
Unescape Escape 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

8
mld_dsp_renum.f90
Unescape Escape 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

10
mld_dumf_bld.f90
Unescape Escape 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

24
mld_slu_impl.c
Unescape Escape 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 */

24
mld_slud_impl.c
Unescape Escape 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 */

24
mld_umf_impl.c
Unescape Escape 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,

23
mld_zaggrmap_bld.f90
Unescape Escape 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

26
mld_zaggrmat_asb.F90
Unescape Escape 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

13
mld_zasmat_bld.f90
Unescape Escape 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

18
mld_zbaseprec_aply.f90
Unescape Escape 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

20
mld_zbaseprec_bld.f90
Unescape Escape 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

42
mld_zbjac_aply.f90
Unescape Escape 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

38
mld_zbjac_bld.f90
Unescape Escape 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

13
mld_zdiagsc_bld.f90
Unescape Escape 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

12
mld_zilu_bld.f90
Unescape Escape 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

16
mld_zilu_fct.f90
Unescape Escape 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

82
mld_zmlprec_aply.f90
Unescape Escape 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

16
mld_zmlprec_bld.f90
Unescape Escape 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

30
mld_zprec_aply.f90
Unescape Escape 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

10
mld_zslu_bld.f90
Unescape Escape 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

24
mld_zslu_impl.c
Unescape Escape 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 */

10
mld_zslud_bld.f90
Unescape Escape 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

24
mld_zslud_impl.c
Unescape Escape 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 */

8
mld_zsp_renum.f90
Unescape Escape 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

10
mld_zumf_bld.f90
Unescape Escape 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

24
mld_zumf_impl.c
Unescape Escape 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,

Write Preview
Loading…
Cancel
Save