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

mld2p4-2:

Browse Source 
Makefile
 mld_cmlprec_aply.f90
 mld_dmlprec_aply.f90
 mld_smlprec_aply.f90
 mld_zmlprec_aply.f90
 mld_zslud_bld.f90

Further advance on double complex.
stopcriterion
Salvatore Filippone 14 years ago
parent 84aa2586bc
commit 675993666f
6 changed files with 725 additions and 1170 deletions
Show Stats Download Patch File Download Diff File

1
mlprec/Makefile
Unescape Escape View File

@ -29,6 +29,7 @@ INNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_dslu_bld.o mld_dumf_bld.o \
mld_cmlprec_aply.o mld_cslud_bld.o mld_caggrmat_asb.o \ mld_cmlprec_aply.o mld_cslud_bld.o mld_caggrmat_asb.o \
mld_zcoarse_bld.o mld_zmlprec_bld.o mld_zslu_bld.o mld_zumf_bld.o \ mld_zcoarse_bld.o mld_zmlprec_bld.o mld_zslu_bld.o mld_zumf_bld.o \
mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \ mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \
mld_zmlprec_aply.o mld_zslud_bld.o mld_zaggrmat_asb.o \
$(MPFOBJS) $(MPFOBJS)
# #

39
mlprec/mld_cmlprec_aply.f90
Unescape Escape View File

@ -357,7 +357,8 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
nlev = size(p%precv) nlev = size(p%precv)
allocate(mlprec_wrk(nlev),stat=info) allocate(mlprec_wrk(nlev),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='Allocate')
goto 9999 goto 9999
end if end if
level = 1 level = 1
@ -379,7 +380,8 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Inner prec aply') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Inner prec aply')
goto 9999 goto 9999
end if end if
@ -387,7 +389,8 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
& p%precv(level)%base_desc,info) & p%precv(level)%base_desc,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error final update') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error final update')
goto 9999 goto 9999
end if end if
@ -432,7 +435,8 @@ contains
nlev = size(p%precv) nlev = size(p%precv)
if ((level < 1) .or. (level > nlev)) then if ((level < 1) .or. (level > nlev)) then
call psb_errpush(psb_err_internal_error_,name,a_err='wrong call level to inner_ml') call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong call level to inner_ml')
goto 9999 goto 9999
end if end if
ictxt = psb_cd_get_context(p%precv(level)%base_desc) ictxt = psb_cd_get_context(p%precv(level)%base_desc)
@ -459,7 +463,8 @@ contains
! No preconditioning, should not really get here ! No preconditioning, should not really get here
! !
write(0,*) 'MLD_NO_ML_ in inner_ml ',level write(0,*) 'MLD_NO_ML_ in inner_ml ',level
call psb_errpush(psb_err_internal_error_,name,a_err='mld_no_ml_ in mlprc_aply?') call psb_errpush(psb_err_internal_error_,name,&
& a_err='mld_no_ml_ in mlprc_aply?')
goto 9999 goto 9999
case(mld_add_ml_) case(mld_add_ml_)
@ -474,7 +479,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -523,7 +529,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
end if end if
@ -574,7 +581,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -634,7 +642,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -686,7 +695,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -748,7 +758,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
end if end if
@ -791,7 +802,8 @@ contains
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_ ) then if (info /= psb_success_ ) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -814,7 +826,8 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error: residual/baseprec_aply') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply')
goto 9999 goto 9999
end if end if

36
mlprec/mld_dmlprec_aply.f90
Unescape Escape View File

@ -379,7 +379,8 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Inner prec aply') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Inner prec aply')
goto 9999 goto 9999
end if end if
@ -387,7 +388,8 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
& p%precv(level)%base_desc,info) & p%precv(level)%base_desc,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error final update') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error final update')
goto 9999 goto 9999
end if end if
@ -432,7 +434,8 @@ contains
nlev = size(p%precv) nlev = size(p%precv)
if ((level < 1) .or. (level > nlev)) then if ((level < 1) .or. (level > nlev)) then
call psb_errpush(psb_err_internal_error_,name,a_err='wrong call level to inner_ml') call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong call level to inner_ml')
goto 9999 goto 9999
end if end if
ictxt = psb_cd_get_context(p%precv(level)%base_desc) ictxt = psb_cd_get_context(p%precv(level)%base_desc)
@ -459,7 +462,8 @@ contains
! No preconditioning, should not really get here ! No preconditioning, should not really get here
! !
write(0,*) 'MLD_NO_ML_ in inner_ml ',level write(0,*) 'MLD_NO_ML_ in inner_ml ',level
call psb_errpush(psb_err_internal_error_,name,a_err='mld_no_ml_ in mlprc_aply?') call psb_errpush(psb_err_internal_error_,name,&
& a_err='mld_no_ml_ in mlprc_aply?')
goto 9999 goto 9999
case(mld_add_ml_) case(mld_add_ml_)
@ -474,7 +478,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -524,7 +529,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
end if end if
@ -575,7 +581,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -635,7 +642,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -687,7 +695,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -749,7 +758,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
end if end if
@ -792,7 +802,8 @@ contains
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_ ) then if (info /= psb_success_ ) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -815,7 +826,8 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error: residual/baseprec_aply') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply')
goto 9999 goto 9999
end if end if

36
mlprec/mld_smlprec_aply.f90
Unescape Escape View File

@ -379,7 +379,8 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Inner prec aply') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Inner prec aply')
goto 9999 goto 9999
end if end if
@ -387,7 +388,8 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info)
& p%precv(level)%base_desc,info) & p%precv(level)%base_desc,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error final update') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error final update')
goto 9999 goto 9999
end if end if
@ -432,7 +434,8 @@ contains
nlev = size(p%precv) nlev = size(p%precv)
if ((level < 1) .or. (level > nlev)) then if ((level < 1) .or. (level > nlev)) then
call psb_errpush(psb_err_internal_error_,name,a_err='wrong call level to inner_ml') call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong call level to inner_ml')
goto 9999 goto 9999
end if end if
ictxt = psb_cd_get_context(p%precv(level)%base_desc) ictxt = psb_cd_get_context(p%precv(level)%base_desc)
@ -459,7 +462,8 @@ contains
! No preconditioning, should not really get here ! No preconditioning, should not really get here
! !
write(0,*) 'MLD_NO_ML_ in inner_ml ',level write(0,*) 'MLD_NO_ML_ in inner_ml ',level
call psb_errpush(psb_err_internal_error_,name,a_err='mld_no_ml_ in mlprc_aply?') call psb_errpush(psb_err_internal_error_,name,&
& a_err='mld_no_ml_ in mlprc_aply?')
goto 9999 goto 9999
case(mld_add_ml_) case(mld_add_ml_)
@ -474,7 +478,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -524,7 +529,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
end if end if
@ -575,7 +581,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -635,7 +642,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -687,7 +695,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -749,7 +758,8 @@ contains
& p%precv(level)%map,info,work=work) & p%precv(level)%map,info,work=work)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
end if end if
@ -792,7 +802,8 @@ contains
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_ ) then if (info /= psb_success_ ) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error during restriction') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
goto 9999 goto 9999
end if end if
@ -815,7 +826,8 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error: residual/baseprec_aply') call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply')
goto 9999 goto 9999
end if end if

1694
mlprec/mld_zmlprec_aply.f90
View File

File diff suppressed because it is too large Load Diff

89
mlprec/mld_zslud_bld.f90
Unescape Escape View File

@ -84,7 +84,7 @@ subroutine mld_zsludist_bld(a,desc_a,p,info)
& mglob,ifrst,ibcheck,nrow,ncol,npr,npc & mglob,ifrst,ibcheck,nrow,ncol,npr,npc
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if (psb_get_errstatus().ne.0) return
info=psb_success_ info=psb_success_
name='mld_zslud_bld' name='mld_zslud_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -93,47 +93,56 @@ subroutine mld_zsludist_bld(a,desc_a,p,info)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (psb_toupper(a%fida) /= 'CSR') then select type(aa=>a%a)
type is (psb_z_csr_sparse_mat)
!
! WARN: we need to check for a BLOCK distribution (this is the
! distribution required by SuperLU_DIST)
!
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
call psb_loc_to_glob(1,ifrst,desc_a,info)
call psb_loc_to_glob(nrow,ibcheck,desc_a,info)
ibcheck = ibcheck - ifrst + 1
ibcheck = ibcheck - nrow
call psb_amx(ictxt,ibcheck)
if (ibcheck > 0) then
write(0,*) 'Warning: does not look like a BLOCK distribution'
info=psb_err_unsupported_format_
ch_err = aa%get_fmt()
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
mglob = psb_cd_get_global_rows(desc_a)
nzt = aa%get_nzeros()
npr = np
npc = 1
call psb_loc_to_glob(aa%ja(1:nzt),desc_a,info,iact='I')
!
! Compute the LU factorization
!
call mld_zsludist_fact(mglob,nrow,nzt,ifrst,&
& aa%val,aa%irp,aa%ja,p%iprcparm(mld_slud_ptr_),&
& npr, npc, info)
if (info /= psb_success_) then
ch_err='psb_sludist_fact'
call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999
end if
call psb_glob_to_loc(aa%ja(1:nzt),desc_a,info,iact='I')
class default
info=psb_err_unsupported_format_ info=psb_err_unsupported_format_
call psb_errpush(info,name,a_err=a%fida) ch_err = aa%get_fmt()
goto 9999 call psb_errpush(info,name,a_err=ch_err)
endif
!
! WARN: we need to check for a BLOCK distribution (this is the
! distribution required by SuperLU_DIST)
!
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
call psb_loc_to_glob(1,ifrst,desc_a,info)
call psb_loc_to_glob(nrow,ibcheck,desc_a,info)
ibcheck = ibcheck - ifrst + 1
ibcheck = ibcheck - nrow
call psb_amx(ictxt,ibcheck)
if (ibcheck > 0) then
write(0,*) 'Warning: does not look like a BLOCK distribution'
endif
mglob = psb_cd_get_global_rows(desc_a)
nzt = psb_sp_get_nnzeros(a)
npr = np
npc = 1
call psb_loc_to_glob(a%ia1(1:nzt),desc_a,info,iact='I')
!
! Compute the LU factorization
!
call mld_zsludist_fact(mglob,nrow,nzt,ifrst,&
& a%aspk,a%ia2,a%ia1,p%iprcparm(mld_slud_ptr_),&
& npr, npc, info)
if (info /= psb_success_) then
ch_err='psb_sludist_fact'
call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
goto 9999 goto 9999
end if end select
call psb_glob_to_loc(a%ia1(1:nzt),desc_a,info,iact='I')
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save