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

Name changes for constants.

Browse Source
stopcriterion
Salvatore Filippone 19 years ago
parent dc68acd075
commit 8293656ef1
23 changed files with 707 additions and 589 deletions
Show Stats Download Patch File Download Diff File

52
mld_daggrmat_asb.F90
Unescape Escape View File

@ -62,8 +62,8 @@ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
call psb_info(ictxt, me, np)
select case (p%iprcparm(smth_kind_))
case (no_smth_)
select case (p%iprcparm(aggr_kind_))
case (no_smooth_)
call raw_aggregate(info)
@ -73,7 +73,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
end if
if (aggr_dump) call psb_csprt(90+me,ac,head='% Raw aggregate.')
case(smth_omg_,smth_biz_)
case(tent_prol,biz_prol_)
if (aggr_dump) call psb_csprt(70+me,a,head='% Input matrix')
call smooth_aggregate(info)
@ -145,7 +145,7 @@ contains
naggrm1=sum(p%nlaggr(1:me))
if (p%iprcparm(coarse_mat_) == mat_repl_) then
if (p%iprcparm(coarse_mat_) == repl_mat_) then
do i=1, nrow
p%mlia(i) = p%mlia(i) + naggrm1
end do
@ -202,7 +202,7 @@ contains
b%m = naggr
b%k = naggr
if (p%iprcparm(coarse_mat_) == mat_repl_) then
if (p%iprcparm(coarse_mat_) == repl_mat_) then
call psb_cdrep(ntaggr,ictxt,desc_ac,info)
if(info /= 0) then
@ -248,7 +248,7 @@ contains
goto 9999
end if
else if (p%iprcparm(coarse_mat_) == mat_distr_) then
else if (p%iprcparm(coarse_mat_) == distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if(info /= 0) then
@ -364,9 +364,9 @@ contains
naggrm1 = sum(p%nlaggr(1:me))
naggrp1 = sum(p%nlaggr(1:me+1))
ml_global_nmb = ( (p%iprcparm(smth_kind_) == smth_omg_).or.&
& ( (p%iprcparm(smth_kind_) == smth_biz_).and.&
& (p%iprcparm(coarse_mat_) == mat_repl_)) )
ml_global_nmb = ( (p%iprcparm(aggr_kind_) == tent_prol).or.&
& ( (p%iprcparm(aggr_kind_) == biz_prol_).and.&
& (p%iprcparm(coarse_mat_) == repl_mat_)) )
if (ml_global_nmb) then
@ -475,9 +475,9 @@ contains
call psb_sp_scal(am3,p%dorig,info)
if(info /= 0) goto 9999
if (p%iprcparm(om_choice_) == lib_choice_) then
if (p%iprcparm(aggr_eig_) == max_norm_) then
if (p%iprcparm(smth_kind_) == smth_biz_) then
if (p%iprcparm(aggr_kind_) == biz_prol_) then
!
! This only works with CSR.
@ -502,15 +502,15 @@ contains
anorm = psb_spnrmi(am3,desc_a,info)
endif
omega = 4.d0/(3.d0*anorm)
p%dprcparm(smooth_omega_) = omega
p%dprcparm(aggr_damp_) = omega
else if (p%iprcparm(om_choice_) == user_choice_) then
else if (p%iprcparm(aggr_eig_) == user_choice_) then
omega = p%dprcparm(smooth_omega_)
omega = p%dprcparm(aggr_damp_)
else if (p%iprcparm(om_choice_) /= user_choice_) then
else if (p%iprcparm(aggr_eig_) /= user_choice_) then
write(0,*) me,'Error: invalid choice for OMEGA in blaggrmat?? ',&
& p%iprcparm(om_choice_)
& p%iprcparm(aggr_eig_)
end if
@ -621,7 +621,7 @@ contains
call psb_numbmm(a,am1,am3)
if (debug) write(0,*) me,'Done NUMBMM 2'
if (p%iprcparm(smth_kind_) == smth_omg_) then
if (p%iprcparm(aggr_kind_) == tent_prol) then
call psb_transp(am1,am2,fmt='COO')
nzl = am2%infoa(psb_nnz_)
i=0
@ -645,7 +645,7 @@ contains
endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd'
if (p%iprcparm(smth_kind_) == smth_omg_) then
if (p%iprcparm(aggr_kind_) == tent_prol) then
! am2 = ((i-wDA)Ptilde)^T
call psb_sphalo(am3,desc_a,am4,info,clcnv=.false.)
@ -664,7 +664,7 @@ contains
goto 9999
end if
else if (p%iprcparm(smth_kind_) == smth_biz_) then
else if (p%iprcparm(aggr_kind_) == biz_prol_) then
call psb_rwextd(ncol,am3,info)
if(info /= 0) then
@ -706,13 +706,13 @@ contains
if (test_dump) call psb_csprt(80+me,b,head='% Smoothed aggregate AC.')
select case(p%iprcparm(smth_kind_))
select case(p%iprcparm(aggr_kind_))
case(smth_omg_)
case(tent_prol)
select case(p%iprcparm(coarse_mat_))
case(mat_distr_)
case(distr_mat_)
call psb_sp_clone(b,ac,info)
if(info /= 0) goto 9999
@ -802,7 +802,7 @@ contains
am2%m=desc_ac%matrix_data(psb_n_col_)
if (debug) write(0,*) me,'Done ac '
case(mat_repl_)
case(repl_mat_)
!
!
call psb_cdrep(ntaggr,ictxt,desc_ac,info)
@ -854,11 +854,11 @@ contains
end select
case(smth_biz_)
case(biz_prol_)
select case(p%iprcparm(coarse_mat_))
case(mat_distr_)
case(distr_mat_)
call psb_sp_clone(b,ac,info)
if(info /= 0) then
@ -884,7 +884,7 @@ contains
end if
case(mat_repl_)
case(repl_mat_)
!
!

2
mld_dasmat_bld.f90
Unescape Escape View File

@ -124,7 +124,7 @@ Subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if
endif
Else If (ptype == asm_) Then
Else If (ptype == as_) Then
!

25
mld_dbaseprec_aply.f90
Unescape Escape View File

@ -83,7 +83,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999
end select
select case(prec%iprcparm(p_type_))
select case(prec%iprcparm(prec_type_))
case(noprec_)
@ -122,7 +122,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999
end if
case(asm_,ras_,ash_,rash_)
case(as_)
if (prec%iprcparm(n_ovr_)==0) then
! shortcut: this fixes performance for RAS(0) == BJA
@ -180,19 +180,19 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
tx(1:nrow_d) = x(1:nrow_d)
tx(nrow_d+1:isz) = dzero
if (prec%iprcparm(restr_)==psb_halo_) then
if (prec%iprcparm(sub_restr_)==psb_halo_) then
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /=0) then
info=4010
ch_err='psb_halo'
goto 9999
end if
else if (prec%iprcparm(restr_) /= psb_none_) then
else if (prec%iprcparm(sub_restr_) /= psb_none_) then
write(0,*) 'Problem in PRC_APLY: Unknown value for restriction ',&
&prec%iprcparm(restr_)
&prec%iprcparm(sub_restr_)
end if
if (prec%iprcparm(iren_)>0) then
if (prec%iprcparm(sub_ren_)>0) then
call dgelp('N',n_row,1,prec%perm,tx,isz,ww,isz,info)
if(info /=0) then
info=4010
@ -208,7 +208,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999
end if
if (prec%iprcparm(iren_)>0) then
if (prec%iprcparm(sub_ren_)>0) then
call dgelp('N',n_row,1,prec%invperm,ty,isz,ww,isz,info)
if(info /=0) then
info=4010
@ -217,7 +217,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
endif
select case (prec%iprcparm(prol_))
select case (prec%iprcparm(sub_prol_))
case(psb_none_)
! Would work anyway, but since it's supposed to do nothing...
@ -225,7 +225,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case(psb_sum_,psb_avg_)
call psb_ovrl(ty,prec%desc_data,info,&
& update=prec%iprcparm(prol_),work=aux)
& update=prec%iprcparm(sub_prol_),work=aux)
if(info /=0) then
info=4010
ch_err='psb_ovrl'
@ -234,7 +234,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case default
write(0,*) 'Problem in PRC_APLY: Unknown value for prolongation ',&
& prec%iprcparm(prol_)
& prec%iprcparm(sub_prol_)
end select
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
@ -250,9 +250,8 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
endif
end if
case default
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(p_type_),':',&
& min_prec_,noprec_,diag_,bjac_,&
& ras_,asm_,ash_,rash_
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(prec_type_),':',&
& min_prec_,noprec_,diag_,bjac_,as_
end select
call psb_erractionrestore(err_act)

22
mld_dbaseprec_bld.f90
Unescape Escape View File

@ -91,13 +91,13 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
! Should add check to ensure all procs have the same...
!
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
call psb_check_def(p%iprcparm(prec_type_),'base_prec',&
& diag_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(p_type_))
select case(p%iprcparm(prec_type_))
case (noprec_)
! Do nothing.
call psb_cdcpy(desc_a,p%desc_data,info)
@ -119,22 +119,22 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
goto 9999
end if
case(bjac_,asm_)
case(bjac_,as_)
call psb_check_def(p%iprcparm(n_ovr_),'overlap',&
& 0,is_legal_n_ovr)
call psb_check_def(p%iprcparm(restr_),'restriction',&
call psb_check_def(p%iprcparm(sub_restr_),'restriction',&
& psb_halo_,is_legal_restrict)
call psb_check_def(p%iprcparm(prol_),'prolongator',&
call psb_check_def(p%iprcparm(sub_prol_),'prolongator',&
& psb_none_,is_legal_prolong)
call psb_check_def(p%iprcparm(iren_),'renumbering',&
call psb_check_def(p%iprcparm(sub_ren_),'renumbering',&
& renum_none_,is_legal_renum)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
call psb_check_def(p%iprcparm(sub_solve_),'fact',&
& ilu_n_,is_legal_ml_fact)
if (p%iprcparm(f_type_)==f_slud_) then
if (p%iprcparm(sub_solve_)==sludist_) then
p%iprcparm(n_ovr_) = 0
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
if (debug) write(0,*)me, ': Calling mld_bjac_bld'
@ -149,7 +149,7 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
case default
info=4010
ch_err='Unknown p_type_'
ch_err='Unknown prec_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999

36
mld_dbjac_aply.f90
Unescape Escape View File

@ -108,13 +108,13 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
endif
if (debug) then
write(0,*) me,' BJAC_APLY: ',prec%iprcparm(f_type_),prec%iprcparm(jac_sweeps_)
write(0,*) me,' BJAC_APLY: ',prec%iprcparm(sub_solve_),prec%iprcparm(smooth_sweeps_)
end if
if (prec%iprcparm(jac_sweeps_) == 1) then
if (prec%iprcparm(smooth_sweeps_) == 1) then
select case(prec%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
select case(prec%iprcparm(sub_solve_))
case(ilu_n_,ilu_t_)
select case(toupper(trans))
case('N')
@ -136,7 +136,7 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end select
case(f_slu_)
case(slu_)
ww(1:n_row) = x(1:n_row)
@ -150,7 +150,7 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case(f_slud_)
case(sludist_)
!!$ write(0,*) 'Calling SLUDist_solve ',n_row
ww(1:n_row) = x(1:n_row)
@ -165,7 +165,7 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case (f_umf_)
case (umf_)
select case(toupper(trans))
@ -180,11 +180,11 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case default
write(0,*) 'Unknown factorization type in bjac_aply',prec%iprcparm(f_type_)
write(0,*) 'Unknown factorization type in bjac_aply',prec%iprcparm(sub_solve_)
end select
if (debugprt) write(0,*)' Y: ',y(:)
else if (prec%iprcparm(jac_sweeps_) > 1) then
else if (prec%iprcparm(smooth_sweeps_) > 1) then
! Note: we have to add TRANS to this one !!!!!!!!!
@ -203,9 +203,9 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
tx = dzero
ty = dzero
select case(prec%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
do i=1, prec%iprcparm(jac_sweeps_)
select case(prec%iprcparm(sub_solve_))
case(ilu_n_,ilu_t_)
do i=1, prec%iprcparm(smooth_sweeps_)
! X(k+1) = M^-1*(b-N*X(k))
ty(1:n_row) = x(1:n_row)
call psb_spmm(-done,prec%av(ap_nd_),tx,done,ty,&
@ -221,12 +221,12 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
end do
case(f_slud_)
case(sludist_)
write(0,*) 'No sense in having SLUDist with JAC_SWEEPS >1'
info=4010
goto 9999
case(f_slu_)
do i=1, prec%iprcparm(jac_sweeps_)
case(slu_)
do i=1, prec%iprcparm(smooth_sweeps_)
! X(k+1) = M^-1*(b-N*X(k))
ty(1:n_row) = x(1:n_row)
call psb_spmm(-done,prec%av(ap_nd_),tx,done,ty,&
@ -237,8 +237,8 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
tx(1:n_row) = ty(1:n_row)
end do
case(f_umf_)
do i=1, prec%iprcparm(jac_sweeps_)
case(umf_)
do i=1, prec%iprcparm(smooth_sweeps_)
! X(k+1) = M^-1*(b-N*X(k))
ty(1:n_row) = x(1:n_row)
call psb_spmm(-done,prec%av(ap_nd_),tx,done,ty,&
@ -262,7 +262,7 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
else
info = 10
call psb_errpush(info,name,&
& i_err=(/2,prec%iprcparm(jac_sweeps_),0,0,0/))
& i_err=(/2,prec%iprcparm(smooth_sweeps_),0,0,0/))
goto 9999
endif

46
mld_dbjac_bld.f90
Unescape Escape View File

@ -106,9 +106,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
t1= psb_wtime()
if(debug) write(0,*)me,': calling mld_asmat_bld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if(debug) write(0,*)me,': calling mld_asmat_bld',p%iprcparm(prec_type_),p%iprcparm(n_ovr_)
if (debug) call psb_barrier(ictxt)
call mld_asmat_bld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
call mld_asmat_bld(p%iprcparm(prec_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=coofmt)
if (debugprt) then
@ -130,7 +130,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
if (debug) call psb_barrier(ictxt)
select case(p%iprcparm(iren_))
select case(p%iprcparm(sub_ren_))
case (1:)
@ -165,7 +165,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
@ -179,9 +179,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
if (debug) write(0,*) me,' Factoring rows ',&
&atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
select case(p%iprcparm(f_type_))
select case(p%iprcparm(sub_solve_))
case(f_ilu_n_,f_ilu_e_)
case(ilu_n_,ilu_t_)
call psb_ipcoo2csr(atmp,info)
@ -213,7 +213,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
endif
case(f_slu_)
case(slu_)
call psb_ipcoo2csr(atmp,info)
if (info /= 0) then
@ -227,7 +227,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
case(f_umf_)
case(umf_)
call psb_ipcoo2csc(atmp,info,clshr=.true.)
if (info /= 0) then
@ -249,7 +249,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
case default
info=4010
call psb_errpush(info,name,a_err='Unknown f_type_')
call psb_errpush(info,name,a_err='Unknown sub_solve_')
goto 9999
end select
@ -266,12 +266,12 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
case(0) ! No renumbering
select case(p%iprcparm(f_type_))
select case(p%iprcparm(sub_solve_))
case(f_ilu_n_,f_ilu_e_)
case(ilu_n_,ilu_t_)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
atmp%fida='COO'
call psb_csdp(a,atmp,info)
if (info /= 0) then
@ -300,7 +300,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
call psb_sp_free(atmp,info)
end if
@ -335,7 +335,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
endif
case(f_slu_)
case(slu_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
@ -348,7 +348,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck,rowscale=.false.)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
!------------------------------------------------------------------
! Split AC=M+N N off-diagonal part
! Output in COO format.
@ -368,7 +368,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
endif
@ -386,7 +386,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
end if
case(f_slud_)
case(sludist_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
@ -399,7 +399,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck,rowscale=.false.)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
!------------------------------------------------------------------
! Split AC=M+N N off-diagonal part
! Output in COO format.
@ -419,7 +419,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
endif
@ -439,7 +439,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
end if
!!$
case(f_umf_)
case(umf_)
atmp%fida='COO'
@ -453,7 +453,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck,rowscale=.false.)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
!------------------------------------------------------------------
! Split AC=M+N N off-diagonal part
! Output in COO format.
@ -474,7 +474,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
endif
@ -505,7 +505,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
case default
info=4010
call psb_errpush(info,name,a_err='Unknown f_type_')
call psb_errpush(info,name,a_err='Unknown sub_solve_')
goto 9999
end select

66
mld_dmlprec_aply.f90
Unescape Escape View File

@ -138,7 +138,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
goto 9999
case(add_ml_prec_)
case(add_ml_)
!
@ -190,9 +190,9 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%tx(n_row+1:max(n_row,n_col)) = dzero
mlprec_wrk(ilev)%ty(:) = dzero
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
! Smoothed aggregation
!
@ -216,9 +216,9 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end if
if (icm ==mat_repl_) Then
if (icm ==repl_mat_) Then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm/= mat_distr_) Then
else if (icm/= distr_mat_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',icm
endif
@ -234,10 +234,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
call psb_csmm(done,baseprecv(ilev)%av(sm_pr_),mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev-1)%y2l,info)
@ -257,14 +257,14 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
case(mult_ml_prec_)
case(mult_ml)
!
! Multiplicative multilevel
! Pre/post smoothing versions.
!
select case(baseprecv(2)%iprcparm(smth_pos_))
select case(baseprecv(2)%iprcparm(smooth_pos_))
case(post_smooth_)
@ -309,7 +309,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
if (debug) write(0,*) me, 'mlpr_aply starting up sweep ',&
@ -329,7 +329,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%x2l(:) = dzero
mlprec_wrk(ilev)%y2l(:) = dzero
mlprec_wrk(ilev)%tx(:) = dzero
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
! Smoothed aggregation
!
@ -356,17 +356,17 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end if
if (debug) write(0,*) me, 'mlpr_aply possible sum in up sweep ', &
& ilev,icm,associated(baseprecv(ilev)%base_desc),mat_repl_
& ilev,icm,associated(baseprecv(ilev)%base_desc),repl_mat_
if (debug) write(0,*) me, 'mlpr_aply geaxpby in up sweep X', &
& ilev,associated(baseprecv(ilev)%base_desc),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_row_),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_col_),&
& size(mlprec_wrk(ilev)%tx),size(mlprec_wrk(ilev)%x2l)
if (icm == mat_repl_) Then
if (icm == repl_mat_) Then
if (debug) write(0,*) 'Entering psb_sum ',nr2l
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mat_distr_) Then
else if (icm /= distr_mat_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ', icm
endif
@ -389,11 +389,11 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
do ilev=nlev-1, 1, -1
if (debug) write(0,*) me, 'mlpr_aply starting down sweep',ilev
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
ismth = baseprecv(ilev+1)%iprcparm(aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
if (ismth /= no_smth_) then
if (ismth == smth_omg_) &
if (ismth /= no_smooth_) then
if (ismth == tent_prol) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work)
call psb_csmm(done,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
@ -479,7 +479,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
@ -496,7 +496,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%tx(:) = dzero
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
!Smoothed Aggregation
!
@ -520,9 +520,9 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do
end if
if (icm ==mat_repl_) then
if (icm ==repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mat_distr_) then
else if (icm /= distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ', icm
endif
@ -543,12 +543,12 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
do ilev = nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
ismth = baseprecv(ilev+1)%iprcparm(aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
if (ismth == smth_omg_) &
if (ismth == tent_prol) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,&
& baseprecv(ilev+1)%desc_data,info,work=work)
call psb_csmm(done,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
@ -574,7 +574,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(smooth_both_)
case(twoside_smooth_)
!
! Symmetrized smoothing.
@ -635,7 +635,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
allocate(mlprec_wrk(ilev)%ty(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -653,7 +653,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%ty(:) = dzero
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
!Smoothed Aggregation
!
@ -677,9 +677,9 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do
end if
if (icm == mat_repl_) then
if (icm == repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mat_distr_) then
else if (icm /= distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ', icm
endif
@ -704,11 +704,11 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
do ilev=nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
ismth = baseprecv(ilev+1)%iprcparm(aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
if (ismth /= no_smth_) then
if (ismth == smth_omg_) &
if (ismth /= no_smooth_) then
if (ismth == tent_prol) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work)
call psb_csmm(done,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
@ -743,7 +743,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case default
call psb_errpush(4013,name,a_err='wrong smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(smth_pos_),0,0,0,0/))
& i_Err=(/baseprecv(2)%iprcparm(smooth_pos_),0,0,0,0/))
goto 9999
end select

24
mld_dmlprec_bld.f90
Unescape Escape View File

@ -68,26 +68,26 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
goto 9999
endif
call psb_check_def(p%iprcparm(ml_type_),'Multilevel type',&
& mult_ml_prec_,is_legal_ml_type)
& mult_ml,is_legal_ml_type)
call psb_check_def(p%iprcparm(aggr_alg_),'aggregation',&
& loc_aggr_,is_legal_ml_aggr_kind)
call psb_check_def(p%iprcparm(smth_kind_),'Smoother kind',&
& smth_omg_,is_legal_ml_smth_kind)
& dec_aggr_,is_legal_ml_aggr_kind)
call psb_check_def(p%iprcparm(aggr_kind_),'Smoother kind',&
& tent_prol,is_legal_ml_smth_kind)
call psb_check_def(p%iprcparm(coarse_mat_),'Coarse matrix',&
& mat_distr_,is_legal_ml_coarse_mat)
call psb_check_def(p%iprcparm(smth_pos_),'smooth_pos',&
& distr_mat_,is_legal_ml_coarse_mat)
call psb_check_def(p%iprcparm(smooth_pos_),'smooth_pos',&
& pre_smooth_,is_legal_ml_smooth_pos)
!!$ nullify(p%desc_data)
select case(p%iprcparm(f_type_))
case(f_ilu_n_)
call psb_check_def(p%iprcparm(ilu_fill_in_),'Level',0,is_legal_ml_lev)
case(f_ilu_e_)
select case(p%iprcparm(sub_solve_))
case(ilu_n_)
call psb_check_def(p%iprcparm(sub_fill_in_),'Level',0,is_legal_ml_lev)
case(ilu_t_)
call psb_check_def(p%dprcparm(fact_eps_),'Eps',dzero,is_legal_ml_eps)
end select
call psb_check_def(p%dprcparm(smooth_omega_),'omega',dzero,is_legal_omega)
call psb_check_def(p%iprcparm(jac_sweeps_),'Jacobi sweeps',&
call psb_check_def(p%dprcparm(aggr_damp_),'omega',dzero,is_legal_omega)
call psb_check_def(p%iprcparm(smooth_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)

4
mld_dsp_renum.f90
Unescape Escape View File

@ -83,7 +83,7 @@ subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
call psb_csdp(a,atmp,info)
call psb_rwextd(a%m+blck%m,atmp,info,blck,rowscale=.false.)
if (p%iprcparm(iren_)==renum_glb_) then
if (p%iprcparm(sub_ren_)==renum_glb_) then
! This is the renumbering coherent with global indices..
mglob = psb_cd_get_global_rows(desc_a)
@ -113,7 +113,7 @@ subroutine mld_dsp_renum(a,desc_a,blck,p,atmp,info)
enddo
t3 = psb_wtime()
else if (p%iprcparm(iren_)==renum_gps_) then
else if (p%iprcparm(sub_ren_)==renum_gps_) then
call psb_ipcoo2csr(atmp,info)
nztmp = psb_sp_get_nnzeros(atmp)

52
mld_zaggrmat_asb.F90
Unescape Escape View File

@ -62,8 +62,8 @@ subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
call psb_info(ictxt, me, np)
select case (p%iprcparm(smth_kind_))
case (no_smth_)
select case (p%iprcparm(aggr_kind_))
case (no_smooth_)
call raw_aggregate(info)
@ -73,7 +73,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
end if
if (aggr_dump) call psb_csprt(90+me,ac,head='% Raw aggregate.')
case(smth_omg_,smth_biz_)
case(tent_prol,biz_prol_)
call smooth_aggregate(info)
@ -144,7 +144,7 @@ contains
naggrm1=sum(p%nlaggr(1:me))
if (p%iprcparm(coarse_mat_) == mat_repl_) then
if (p%iprcparm(coarse_mat_) == repl_mat_) then
do i=1, nrow
p%mlia(i) = p%mlia(i) + naggrm1
end do
@ -201,7 +201,7 @@ contains
b%m = naggr
b%k = naggr
if (p%iprcparm(coarse_mat_) == mat_repl_) then
if (p%iprcparm(coarse_mat_) == repl_mat_) then
call psb_cdrep(ntaggr,ictxt,desc_ac,info)
if(info /= 0) then
@ -247,7 +247,7 @@ contains
goto 9999
end if
else if (p%iprcparm(coarse_mat_) == mat_distr_) then
else if (p%iprcparm(coarse_mat_) == distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if(info /= 0) then
@ -363,9 +363,9 @@ contains
naggrm1 = sum(p%nlaggr(1:me))
naggrp1 = sum(p%nlaggr(1:me+1))
ml_global_nmb = ( (p%iprcparm(smth_kind_) == smth_omg_).or.&
& ( (p%iprcparm(smth_kind_) == smth_biz_).and.&
& (p%iprcparm(coarse_mat_) == mat_repl_)) )
ml_global_nmb = ( (p%iprcparm(aggr_kind_) == tent_prol).or.&
& ( (p%iprcparm(aggr_kind_) == biz_prol_).and.&
& (p%iprcparm(coarse_mat_) == repl_mat_)) )
if (ml_global_nmb) then
@ -474,9 +474,9 @@ contains
call psb_sp_scal(am3,p%dorig,info)
if(info /= 0) goto 9999
if (p%iprcparm(om_choice_) == lib_choice_) then
if (p%iprcparm(aggr_eig_) == max_norm_) then
if (p%iprcparm(smth_kind_) == smth_biz_) then
if (p%iprcparm(aggr_kind_) == biz_prol_) then
!
! This only works with CSR.
@ -501,15 +501,15 @@ contains
anorm = psb_spnrmi(am3,desc_a,info)
endif
omega = 4.d0/(3.d0*anorm)
p%dprcparm(smooth_omega_) = omega
p%dprcparm(aggr_damp_) = omega
else if (p%iprcparm(om_choice_) == user_choice_) then
else if (p%iprcparm(aggr_eig_) == user_choice_) then
omega = p%dprcparm(smooth_omega_)
omega = p%dprcparm(aggr_damp_)
else if (p%iprcparm(om_choice_) /= user_choice_) then
else if (p%iprcparm(aggr_eig_) /= user_choice_) then
write(0,*) me,'Error: invalid choice for OMEGA in blaggrmat?? ',&
& p%iprcparm(om_choice_)
& p%iprcparm(aggr_eig_)
end if
@ -620,7 +620,7 @@ contains
call psb_numbmm(a,am1,am3)
if (debug) write(0,*) me,'Done NUMBMM 2'
if (p%iprcparm(smth_kind_) == smth_omg_) then
if (p%iprcparm(aggr_kind_) == tent_prol) then
call psb_transc(am1,am2,fmt='COO')
nzl = am2%infoa(psb_nnz_)
i=0
@ -644,7 +644,7 @@ contains
endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd'
if (p%iprcparm(smth_kind_) == smth_omg_) then
if (p%iprcparm(aggr_kind_) == tent_prol) then
! am2 = ((i-wDA)Ptilde)^T
call psb_sphalo(am3,desc_a,am4,info,clcnv=.false.)
@ -663,7 +663,7 @@ contains
goto 9999
end if
else if (p%iprcparm(smth_kind_) == smth_biz_) then
else if (p%iprcparm(aggr_kind_) == biz_prol_) then
call psb_rwextd(ncol,am3,info)
if(info /= 0) then
@ -705,13 +705,13 @@ contains
if (test_dump) call psb_csprt(80+me,b,head='% Smoothed aggregate AC.')
select case(p%iprcparm(smth_kind_))
select case(p%iprcparm(aggr_kind_))
case(smth_omg_)
case(tent_prol)
select case(p%iprcparm(coarse_mat_))
case(mat_distr_)
case(distr_mat_)
call psb_sp_clone(b,ac,info)
if(info /= 0) goto 9999
@ -800,7 +800,7 @@ contains
end if
am2%m=desc_ac%matrix_data(psb_n_col_)
case(mat_repl_)
case(repl_mat_)
!
!
call psb_cdrep(ntaggr,ictxt,desc_ac,info)
@ -852,11 +852,11 @@ contains
end select
case(smth_biz_)
case(biz_prol_)
select case(p%iprcparm(coarse_mat_))
case(mat_distr_)
case(distr_mat_)
call psb_sp_clone(b,ac,info)
if(info /= 0) then
@ -880,7 +880,7 @@ contains
end if
case(mat_repl_)
case(repl_mat_)
!
!

2
mld_zasmat_bld.f90
Unescape Escape View File

@ -123,7 +123,7 @@ Subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if
endif
Else If (ptype == asm_) Then
Else If (ptype == as_) Then
!

25
mld_zbaseprec_aply.f90
Unescape Escape View File

@ -82,7 +82,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999
end select
select case(prec%iprcparm(p_type_))
select case(prec%iprcparm(prec_type_))
case(noprec_)
@ -121,7 +121,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999
end if
case(asm_,ras_,ash_,rash_)
case(as_)
if (prec%iprcparm(n_ovr_)==0) then
! shortcut: this fixes performance for RAS(0) == BJA
@ -176,19 +176,19 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
tx(1:nrow_d) = x(1:nrow_d)
tx(nrow_d+1:isz) = zzero
if (prec%iprcparm(restr_)==psb_halo_) then
if (prec%iprcparm(sub_restr_)==psb_halo_) then
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /=0) then
info=4010
ch_err='psb_halo'
goto 9999
end if
else if (prec%iprcparm(restr_) /= psb_none_) then
else if (prec%iprcparm(sub_restr_) /= psb_none_) then
write(0,*) 'Problem in PRC_APLY: Unknown value for restriction ',&
&prec%iprcparm(restr_)
&prec%iprcparm(sub_restr_)
end if
if (prec%iprcparm(iren_)>0) then
if (prec%iprcparm(sub_ren_)>0) then
call zgelp('N',n_row,1,prec%perm,tx,isz,ww,isz,info)
if(info /=0) then
info=4010
@ -204,7 +204,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999
end if
if (prec%iprcparm(iren_)>0) then
if (prec%iprcparm(sub_ren_)>0) then
call zgelp('N',n_row,1,prec%invperm,ty,isz,ww,isz,info)
if(info /=0) then
info=4010
@ -213,7 +213,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if
endif
select case (prec%iprcparm(prol_))
select case (prec%iprcparm(sub_prol_))
case(psb_none_)
! Would work anyway, but since it's supposed to do nothing...
@ -221,7 +221,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case(psb_sum_,psb_avg_)
call psb_ovrl(ty,prec%desc_data,info,&
& update=prec%iprcparm(prol_),work=aux)
& update=prec%iprcparm(sub_prol_),work=aux)
if(info /=0) then
info=4010
ch_err='psb_ovrl'
@ -230,7 +230,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case default
write(0,*) 'Problem in PRC_APLY: Unknown value for prolongation ',&
& prec%iprcparm(prol_)
& prec%iprcparm(sub_prol_)
end select
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
@ -246,9 +246,8 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
endif
end if
case default
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(p_type_),':',&
& min_prec_,noprec_,diag_,bjac_,&
& ras_,asm_,ash_,rash_
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(prec_type_),':',&
& min_prec_,noprec_,diag_,bjac_,as_
end select
call psb_erractionrestore(err_act)

22
mld_zbaseprec_bld.f90
Unescape Escape View File

@ -91,13 +91,13 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
! Should add check to ensure all procs have the same...
!
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
call psb_check_def(p%iprcparm(prec_type_),'base_prec',&
& diag_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(p_type_))
select case(p%iprcparm(prec_type_))
case (noprec_)
! Do nothing.
call psb_cdcpy(desc_a,p%desc_data,info)
@ -119,22 +119,22 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
goto 9999
end if
case (bjac_,asm_)
case (bjac_,as_)
call psb_check_def(p%iprcparm(n_ovr_),'overlap',&
& 0,is_legal_n_ovr)
call psb_check_def(p%iprcparm(restr_),'restriction',&
call psb_check_def(p%iprcparm(sub_restr_),'restriction',&
& psb_halo_,is_legal_restrict)
call psb_check_def(p%iprcparm(prol_),'prolongator',&
call psb_check_def(p%iprcparm(sub_prol_),'prolongator',&
& psb_none_,is_legal_prolong)
call psb_check_def(p%iprcparm(iren_),'renumbering',&
call psb_check_def(p%iprcparm(sub_ren_),'renumbering',&
& renum_none_,is_legal_renum)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
call psb_check_def(p%iprcparm(sub_solve_),'fact',&
& ilu_n_,is_legal_ml_fact)
if (p%iprcparm(f_type_)==f_slud_) then
if (p%iprcparm(sub_solve_)==sludist_) then
p%iprcparm(n_ovr_) = 0
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
if (debug) write(0,*)me, ': Calling mld_bjac_bld'
@ -149,7 +149,7 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
case default
info=4010
ch_err='Unknown p_type_'
ch_err='Unknown prec_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999

34
mld_zbjac_aply.f90
Unescape Escape View File

@ -108,11 +108,11 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
endif
if (prec%iprcparm(jac_sweeps_) == 1) then
if (prec%iprcparm(smooth_sweeps_) == 1) then
select case(prec%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
select case(prec%iprcparm(sub_solve_))
case(ilu_n_,ilu_t_)
select case(toupper(trans))
case('N')
@ -134,7 +134,7 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end select
case(f_slu_)
case(slu_)
ww(1:n_row) = x(1:n_row)
@ -150,7 +150,7 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case(f_slud_)
case(sludist_)
!!$ write(0,*) 'Calling SLUDist_solve ',n_row
ww(1:n_row) = x(1:n_row)
@ -167,7 +167,7 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case (f_umf_)
case (umf_)
select case(toupper(trans))
@ -184,11 +184,11 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case default
write(0,*) 'Unknown factorization type in bjac_aply',prec%iprcparm(f_type_)
write(0,*) 'Unknown factorization type in bjac_aply',prec%iprcparm(sub_solve_)
end select
if (debugprt) write(0,*)' Y: ',y(:)
else if (prec%iprcparm(jac_sweeps_) > 1) then
else if (prec%iprcparm(smooth_sweeps_) > 1) then
! Note: we have to add TRANS to this one !!!!!!!!!
@ -207,9 +207,9 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
tx = zzero
ty = zzero
select case(prec%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
do i=1, prec%iprcparm(jac_sweeps_)
select case(prec%iprcparm(sub_solve_))
case(ilu_n_,ilu_t_)
do i=1, prec%iprcparm(smooth_sweeps_)
! X(k+1) = M^-1*(b-N*X(k))
ty(1:n_row) = x(1:n_row)
call psb_spmm(-zone,prec%av(ap_nd_),tx,zone,ty,&
@ -225,12 +225,12 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
end do
case(f_slud_)
case(sludist_)
write(0,*) 'No sense in having SLUDist with JAC_SWEEPS >1'
info=4010
goto 9999
case(f_slu_)
do i=1, prec%iprcparm(jac_sweeps_)
case(slu_)
do i=1, prec%iprcparm(smooth_sweeps_)
! X(k+1) = M^-1*(b-N*X(k))
ty(1:n_row) = x(1:n_row)
call psb_spmm(-zone,prec%av(ap_nd_),tx,zone,ty,&
@ -241,8 +241,8 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
tx(1:n_row) = ty(1:n_row)
end do
case(f_umf_)
do i=1, prec%iprcparm(jac_sweeps_)
case(umf_)
do i=1, prec%iprcparm(smooth_sweeps_)
! X(k+1) = M^-1*(b-N*X(k))
ty(1:n_row) = x(1:n_row)
call psb_spmm(-zone,prec%av(ap_nd_),tx,zone,ty,&
@ -266,7 +266,7 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
else
info = 10
call psb_errpush(info,name,&
& i_err=(/2,prec%iprcparm(jac_sweeps_),0,0,0/))
& i_err=(/2,prec%iprcparm(smooth_sweeps_),0,0,0/))
goto 9999
endif

46
mld_zbjac_bld.f90
Unescape Escape View File

@ -107,9 +107,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
t1= psb_wtime()
if(debug) write(0,*)me,': calling mld_asmat_bld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if(debug) write(0,*)me,': calling mld_asmat_bld',p%iprcparm(prec_type_),p%iprcparm(n_ovr_)
if (debug) call psb_barrier(ictxt)
call mld_asmat_bld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
call mld_asmat_bld(p%iprcparm(prec_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=coofmt)
if(info/=0) then
@ -122,7 +122,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
if (debug) call psb_barrier(ictxt)
select case(p%iprcparm(iren_))
select case(p%iprcparm(sub_ren_))
case (1:)
@ -157,7 +157,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
@ -171,9 +171,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
if (debug) write(0,*) me,' Factoring rows ',&
&atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
select case(p%iprcparm(f_type_))
select case(p%iprcparm(sub_solve_))
case(f_ilu_n_,f_ilu_e_)
case(ilu_n_,ilu_t_)
call psb_ipcoo2csr(atmp,info)
@ -205,7 +205,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
endif
case(f_slu_)
case(slu_)
call psb_ipcoo2csr(atmp,info)
if (info /= 0) then
@ -219,7 +219,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
goto 9999
end if
case(f_umf_)
case(umf_)
call psb_ipcoo2csc(atmp,info,clshr=.true.)
if (info /= 0) then
@ -241,7 +241,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
case default
info=4010
call psb_errpush(info,name,a_err='Unknown f_type_')
call psb_errpush(info,name,a_err='Unknown sub_solve_')
goto 9999
end select
@ -258,12 +258,12 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
case(0) ! No renumbering
select case(p%iprcparm(f_type_))
select case(p%iprcparm(sub_solve_))
case(f_ilu_n_,f_ilu_e_)
case(ilu_n_,ilu_t_)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
atmp%fida='COO'
call psb_csdp(a,atmp,info)
if (info /= 0) then
@ -293,7 +293,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
call psb_sp_free(atmp,info)
end if
@ -328,7 +328,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
endif
case(f_slu_)
case(slu_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
@ -341,7 +341,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck,rowscale=.false.)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
!------------------------------------------------------------------
! Split AC=M+N N off-diagonal part
! Output in COO format.
@ -361,7 +361,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
endif
@ -379,7 +379,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
end if
case(f_slud_)
case(sludist_)
atmp%fida='COO'
call psb_csdp(a,atmp,info)
@ -392,7 +392,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck,rowscale=.false.)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
!------------------------------------------------------------------
! Split AC=M+N N off-diagonal part
! Output in COO format.
@ -412,7 +412,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
endif
@ -432,7 +432,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
end if
!!$
case(f_umf_)
case(umf_)
atmp%fida='COO'
@ -446,7 +446,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck,rowscale=.false.)
if (p%iprcparm(jac_sweeps_) > 1) then
if (p%iprcparm(smooth_sweeps_) > 1) then
!------------------------------------------------------------------
! Split AC=M+N N off-diagonal part
! Output in COO format.
@ -467,7 +467,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
p%iprcparm(smooth_sweeps_) = 1
end if
endif
@ -498,7 +498,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
case default
info=4010
call psb_errpush(info,name,a_err='Unknown f_type_')
call psb_errpush(info,name,a_err='Unknown sub_solve_')
goto 9999
end select

66
mld_zmlprec_aply.f90
Unescape Escape View File

@ -138,7 +138,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
goto 9999
case(add_ml_prec_)
case(add_ml_)
!
@ -191,9 +191,9 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%ty(:) = zzero
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
! Smoothed aggregation
!
@ -217,9 +217,9 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end if
if (icm ==mat_repl_) Then
if (icm ==repl_mat_) Then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm/= mat_distr_) Then
else if (icm/= distr_mat_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',icm
endif
@ -235,10 +235,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
call psb_csmm(zone,baseprecv(ilev)%av(sm_pr_),mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev-1)%y2l,info)
@ -258,14 +258,14 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
case(mult_ml_prec_)
case(mult_ml)
!
! Multiplicative multilevel
! Pre/post smoothing versions.
!
select case(baseprecv(2)%iprcparm(smth_pos_))
select case(baseprecv(2)%iprcparm(smooth_pos_))
case(post_smooth_)
@ -310,7 +310,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
if (debug) write(0,*) me, 'mlpr_aply starting up sweep ',&
@ -330,7 +330,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%x2l(:) = zzero
mlprec_wrk(ilev)%y2l(:) = zzero
mlprec_wrk(ilev)%tx(:) = zzero
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
! Smoothed aggregation
!
@ -356,17 +356,17 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end if
if (debug) write(0,*) me, 'mlpr_aply possible sum in up sweep ', &
& ilev,icm,associated(baseprecv(ilev)%base_desc),mat_repl_
& ilev,icm,associated(baseprecv(ilev)%base_desc),repl_mat_
if (debug) write(0,*) me, 'mlpr_aply geaxpby in up sweep X', &
& ilev,associated(baseprecv(ilev)%base_desc),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_row_),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_col_),&
& size(mlprec_wrk(ilev)%tx),size(mlprec_wrk(ilev)%x2l)
if (icm == mat_repl_) Then
if (icm == repl_mat_) Then
if (debug) write(0,*) 'Entering psb_sum ',nr2l
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mat_distr_) Then
else if (icm /= distr_mat_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ', icm
endif
call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,&
@ -383,11 +383,11 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
do ilev=nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
ismth = baseprecv(ilev+1)%iprcparm(aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
if (ismth /= no_smth_) then
if (ismth == smth_omg_) &
if (ismth /= no_smooth_) then
if (ismth == tent_prol) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work)
call psb_csmm(zone,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
@ -473,7 +473,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
@ -490,7 +490,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%tx(:) = zzero
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
!Smoothed Aggregation
!
@ -514,9 +514,9 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do
end if
if (icm ==mat_repl_) then
if (icm ==repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mat_distr_) then
else if (icm /= distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ', icm
endif
@ -537,12 +537,12 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
do ilev = nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
ismth = baseprecv(ilev+1)%iprcparm(aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
if (ismth == smth_omg_) &
if (ismth == tent_prol) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,&
& baseprecv(ilev+1)%desc_data,info,work=work)
call psb_csmm(zone,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
@ -568,7 +568,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(smooth_both_)
case(twoside_smooth_)
!
! Symmetrized smoothing.
@ -629,7 +629,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%desc_data)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%desc_data)
ismth = baseprecv(ilev)%iprcparm(smth_kind_)
ismth = baseprecv(ilev)%iprcparm(aggr_kind_)
icm = baseprecv(ilev)%iprcparm(coarse_mat_)
allocate(mlprec_wrk(ilev)%ty(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -647,7 +647,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%ty(:) = zzero
if (ismth /= no_smth_) then
if (ismth /= no_smooth_) then
!
!Smoothed Aggregation
!
@ -671,9 +671,9 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do
end if
if (icm == mat_repl_) then
if (icm == repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mat_distr_) then
else if (icm /= distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ', icm
endif
@ -698,11 +698,11 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
do ilev=nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(smth_kind_)
ismth = baseprecv(ilev+1)%iprcparm(aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
if (ismth /= no_smth_) then
if (ismth == smth_omg_) &
if (ismth /= no_smooth_) then
if (ismth == tent_prol) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work)
call psb_csmm(zone,baseprecv(ilev+1)%av(sm_pr_),mlprec_wrk(ilev+1)%y2l,&
@ -737,7 +737,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case default
call psb_errpush(4013,name,a_err='wrong smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(smth_pos_),0,0,0,0/))
& i_Err=(/baseprecv(2)%iprcparm(smooth_pos_),0,0,0,0/))
goto 9999
end select

24
mld_zmlprec_bld.f90
Unescape Escape View File

@ -69,26 +69,26 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
goto 9999
endif
call psb_check_def(p%iprcparm(ml_type_),'Multilevel type',&
& mult_ml_prec_,is_legal_ml_type)
& mult_ml,is_legal_ml_type)
call psb_check_def(p%iprcparm(aggr_alg_),'aggregation',&
& loc_aggr_,is_legal_ml_aggr_kind)
call psb_check_def(p%iprcparm(smth_kind_),'Smoother kind',&
& smth_omg_,is_legal_ml_smth_kind)
& dec_aggr_,is_legal_ml_aggr_kind)
call psb_check_def(p%iprcparm(aggr_kind_),'Smoother kind',&
& tent_prol,is_legal_ml_smth_kind)
call psb_check_def(p%iprcparm(coarse_mat_),'Coarse matrix',&
& mat_distr_,is_legal_ml_coarse_mat)
call psb_check_def(p%iprcparm(smth_pos_),'smooth_pos',&
& distr_mat_,is_legal_ml_coarse_mat)
call psb_check_def(p%iprcparm(smooth_pos_),'smooth_pos',&
& pre_smooth_,is_legal_ml_smooth_pos)
!!$ nullify(p%desc_data)
select case(p%iprcparm(f_type_))
case(f_ilu_n_)
call psb_check_def(p%iprcparm(ilu_fill_in_),'Level',0,is_legal_ml_lev)
case(f_ilu_e_)
select case(p%iprcparm(sub_solve_))
case(ilu_n_)
call psb_check_def(p%iprcparm(sub_fill_in_),'Level',0,is_legal_ml_lev)
case(ilu_t_)
call psb_check_def(p%dprcparm(fact_eps_),'Eps',dzero,is_legal_ml_eps)
end select
call psb_check_def(p%dprcparm(smooth_omega_),'omega',dzero,is_legal_omega)
call psb_check_def(p%iprcparm(jac_sweeps_),'Jacobi sweeps',&
call psb_check_def(p%dprcparm(aggr_damp_),'omega',dzero,is_legal_omega)
call psb_check_def(p%iprcparm(smooth_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)

4
mld_zsp_renum.f90
Unescape Escape View File

@ -70,7 +70,7 @@ subroutine mld_zsp_renum(a,desc_a,blck,p,atmp,info)
! 1. Global column indices
! (2. GPS band reduction disabled for the time being)
if (p%iprcparm(iren_)==renum_glb_) then
if (p%iprcparm(sub_ren_)==renum_glb_) then
atmp%m = a%m + blck%m
atmp%k = a%k
atmp%fida='CSR'
@ -183,7 +183,7 @@ subroutine mld_zsp_renum(a,desc_a,blck,p,atmp,info)
deallocate(itmp,itmp2,ztmp)
else if (p%iprcparm(iren_)==renum_gps_) then
else if (p%iprcparm(sub_ren_)==renum_gps_) then
atmp%m = a%m + blck%m
atmp%k = a%k

148
psb_dprecinit.f90
Unescape Escape View File

@ -65,13 +65,13 @@ subroutine psb_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = noprec_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(prec_type_) = noprec_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = f_none_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('DIAG')
nlev_ = 1
@ -80,14 +80,14 @@ subroutine psb_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = diag_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = diag_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = f_none_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('BJAC')
nlev_ = 1
@ -96,15 +96,15 @@ subroutine psb_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('AS')
nlev_ = 1
@ -113,15 +113,15 @@ subroutine psb_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = asm_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = as_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('ML')
@ -139,58 +139,58 @@ subroutine psb_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = asm_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = as_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml_prec_
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = loc_aggr_
p%baseprecv(ilev_)%iprcparm(smth_kind_) = smth_omg_
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = mat_distr_
p%baseprecv(ilev_)%iprcparm(smth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(om_choice_) = lib_choice_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = 4.d0/3.d0
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = dec_aggr_
p%baseprecv(ilev_)%iprcparm(aggr_kind_) = tent_prol
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = distr_mat_
p%baseprecv(ilev_)%iprcparm(smooth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(aggr_eig_) = max_norm_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
p%baseprecv(ilev_)%dprcparm(aggr_damp_) = 4.d0/3.d0
end do
ilev_ = nlev_
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml_prec_
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = loc_aggr_
p%baseprecv(ilev_)%iprcparm(smth_kind_) = smth_omg_
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = mat_distr_
p%baseprecv(ilev_)%iprcparm(smth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(om_choice_) = lib_choice_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_umf_
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 4
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = 4.d0/3.d0
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = dec_aggr_
p%baseprecv(ilev_)%iprcparm(aggr_kind_) = tent_prol
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = distr_mat_
p%baseprecv(ilev_)%iprcparm(smooth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(aggr_eig_) = max_norm_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = umf_
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 4
p%baseprecv(ilev_)%dprcparm(aggr_damp_) = 4.d0/3.d0
case default
write(0,*) 'Unknown preconditioner type request "',ptype,'"'

117
psb_dprecset.f90
Unescape Escape View File

@ -49,12 +49,6 @@ subroutine psb_dprecseti(p,what,val,info,ilev)
info = 0
if (present(ilev)) then
ilev_ = ilev
else
ilev_ = 1
end if
if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
@ -62,6 +56,12 @@ subroutine psb_dprecseti(p,what,val,info,ilev)
endif
nlev_ = size(p%baseprecv)
if (present(ilev)) then
ilev_ = ilev
else
ilev_ = 1
end if
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
info = -1
@ -74,25 +74,90 @@ subroutine psb_dprecseti(p,what,val,info,ilev)
endif
if (present(ilev)) then
if (ilev_ == 1) then
! Rules for fine level are slightly different.
select case(what)
case(prec_type_,sub_solve_,sub_restr_,sub_prol_,sub_ren_,n_ovr_,sub_fill_in_,smooth_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
else if (ilev_ > 1) then
select case(what)
case(prec_type_,sub_solve_,sub_restr_,sub_prol_,sub_ren_,n_ovr_,sub_fill_in_,&
& smooth_sweeps_,ml_type_,aggr_alg_,aggr_kind_,coarse_mat_,&
& smooth_pos_,aggr_eig_)
p%baseprecv(ilev_)%iprcparm(what) = val
case(coarse_solve_)
if (ilev_ /= nlev_) then
write(0,*) 'Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(sub_solve_) = val
case(coarse_sweeps_)
if (ilev_ /= nlev_) then
write(0,*) 'Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = val
case(coarse_fill_in_)
if (ilev_ /= nlev_) then
write(0,*) 'Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
endif
else if (.not.present(ilev)) then
select case(what)
case(prec_type_,sub_solve_,sub_restr_,sub_prol_,sub_ren_,n_ovr_,sub_fill_in_,&
& smooth_sweeps_,ml_type_,aggr_alg_,aggr_kind_,coarse_mat_,&
& smooth_pos_,aggr_eig_)
do ilev_=1,nlev_-1
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
end do
case(coarse_solve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(nlev_)%iprcparm(sub_solve_) = val
case(coarse_sweeps_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(nlev_)%iprcparm(smooth_sweeps_) = val
case(coarse_fill_in_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(nlev_)%iprcparm(sub_fill_in_) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
if (ilev_ == 1) then
! Rules for fine level are slightly different.
select case(what)
case(p_type_,f_type_,restr_,prol_,iren_,n_ovr_,ilu_fill_in_,jac_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
else if (ilev_ > 1) then
select case(what)
case(p_type_,f_type_,restr_,prol_,iren_,n_ovr_,ilu_fill_in_,jac_sweeps_,&
& ml_type_,aggr_alg_,smth_kind_,coarse_mat_,smth_pos_,om_choice_)
p%baseprecv(ilev_)%iprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
endif
end subroutine psb_dprecseti
@ -140,14 +205,14 @@ subroutine psb_dprecsetd(p,what,val,info,ilev)
! Rules for fine level are slightly different.
select case(what)
! Right now we don't have any at base level. Will change when
! we implement F_ILU_E_
! we implement ilu_t_
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
else if (ilev_ > 1) then
select case(what)
case(smooth_omega_)
case(aggr_damp_)
p%baseprecv(ilev_)%dprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'

240
psb_prec_type.f90
Unescape Escape View File

@ -132,20 +132,19 @@ module psb_prec_type
! Entries in iprcparm
integer, parameter :: p_type_=1
integer, parameter :: f_type_=2
integer, parameter :: restr_=3
integer, parameter :: prol_=4
integer, parameter :: iren_=5
integer, parameter :: prec_type_=1
integer, parameter :: sub_solve_=2
integer, parameter :: sub_restr_=3
integer, parameter :: sub_prol_=4
integer, parameter :: sub_ren_=5
integer, parameter :: n_ovr_=6
integer, parameter :: ilu_fill_in_=8
integer, parameter :: jac_sweeps_=9
integer, parameter :: sub_fill_in_=8
integer, parameter :: smooth_sweeps_=9
integer, parameter :: ml_type_=10
integer, parameter :: smth_pos_=11
integer, parameter :: smooth_pos_=11
integer, parameter :: aggr_alg_=12
integer, parameter :: smth_kind_=13
integer, parameter :: om_choice_=14
integer, parameter :: aggr_eig_ =15
integer, parameter :: aggr_kind_=13
integer, parameter :: aggr_eig_=14
integer, parameter :: coarse_mat_=16
!! 2 ints for 64 bit versions
integer, parameter :: slu_ptr_=17
@ -158,38 +157,35 @@ module psb_prec_type
integer, parameter :: coarse_fill_in_=27
integer, parameter :: ifpsz=32
! Legal values for entry: p_type_
! Legal values for entry: prec_type_
integer, parameter :: min_prec_=0, noprec_=0, diag_=1, bjac_=2,&
& ras_=3,asm_=4, ash_=5, rash_=6, ras2lv_=7, ras2lvm_=8,&
& lv2mras_=9, lv2smth_=10, lv2lsm_=11, sl2sm_=12, superlu_=13,&
& new_loc_smth_=14, new_glb_smth_=15, ag2lsm_=16,&
& msy2l_=18, msy2g_=19, max_prec_=19
& as_=3, max_prec_=3
! Legal values for entry: ml_type_
integer, parameter :: no_ml_=0, add_ml_prec_=1, mult_ml_prec_=2
integer, parameter :: no_ml_=0, add_ml_=1, mult_ml=2
integer, parameter :: new_ml_prec_=3, max_ml_=new_ml_prec_
! Legal values for entry: smth_pos_
integer, parameter :: pre_smooth_=1, post_smooth_=2, smooth_both_=3,&
& max_smooth_=smooth_both_
! Legal values for entry: f_type_
integer, parameter :: f_none_=0,f_ilu_n_=1,f_ilu_e_=2,f_slu_=3
integer, parameter :: f_umf_=4, f_slud_=5
! Legal values for entry: smooth_pos_
integer, parameter :: pre_smooth_=1, post_smooth_=2, twoside_smooth_=3,&
& max_smooth_=twoside_smooth_
! Legal values for entry: sub_solve_
integer, parameter :: f_none_=0,ilu_n_=1,ilu_t_=2,slu_=3
integer, parameter :: umf_=4, sludist_=5
! Legal values for entry: aggr_alg_
integer, parameter :: loc_aggr_=0, glb_aggr_=1, new_loc_aggr_=2
integer, parameter :: dec_aggr_=0, glb_aggr_=1, new_dec_aggr_=2
integer, parameter :: new_glb_aggr_=3, max_aggr_=new_glb_aggr_
! Legal values for entry: smth_kind_
integer, parameter :: no_smth_=0, smth_omg_=1, smth_biz_=2
! Legal values for entry: om_choice_
integer, parameter :: lib_choice_=0, user_choice_=999
! Legal values for entry: aggr_kind_
integer, parameter :: no_smooth_=0, tent_prol=1, biz_prol_=2
! Legal values for entry: aggr_eig_
integer, parameter :: max_norm_=0, user_choice_=999
! Legal values for entry: coarse_mat_
integer, parameter :: mat_distr_=0, mat_repl_=1
integer, parameter :: distr_mat_=0, repl_mat_=1
! Legal values for entry: prec_status_
integer, parameter :: prec_built=98765
! Legal values for entry: iren_
! Legal values for entry: sub_ren_
integer, parameter :: renum_none_=0, renum_glb_=1, renum_gps_=2
! Entries in dprcparm: ILU(E) epsilon, smoother omega
integer, parameter :: fact_eps_=1
integer, parameter :: smooth_omega_=2
integer, parameter :: aggr_damp_=2
integer, parameter :: aggr_thresh_=3
integer, parameter :: dfpsz=4
! Fields for sparse matrices ensembles stored in av()
@ -290,14 +286,14 @@ contains
if (allocated(prec%iprcparm)) then
val = val + 4 * size(prec%iprcparm)
if (prec%iprcparm(prec_status_) == prec_built) then
select case(prec%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
select case(prec%iprcparm(sub_solve_))
case(ilu_n_,ilu_t_)
! do nothing
case(f_slu_)
case(slu_)
write(0,*) 'Should implement check for size of SuperLU data structs'
case(f_umf_)
case(umf_)
write(0,*) 'Should implement check for size of UMFPACK data structs'
case(f_slud_)
case(sludist_)
write(0,*) 'Should implement check for size of SuperLUDist data structs'
case default
end select
@ -329,14 +325,14 @@ contains
if (allocated(prec%iprcparm)) then
val = val + 4 * size(prec%iprcparm)
if (prec%iprcparm(prec_status_) == prec_built) then
select case(prec%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
select case(prec%iprcparm(sub_solve_))
case(ilu_n_,ilu_t_)
! do nothing
case(f_slu_)
case(slu_)
write(0,*) 'Should implement check for size of SuperLU data structs'
case(f_umf_)
case(umf_)
write(0,*) 'Should implement check for size of UMFPACK data structs'
case(f_slud_)
case(sludist_)
write(0,*) 'Should implement check for size of SuperLUDist data structs'
case default
end select
@ -382,23 +378,23 @@ contains
if (allocated(p%baseprecv)) then
if (size(p%baseprecv)>=1) then
write(iout,*) 'Base preconditioner'
select case(p%baseprecv(1)%iprcparm(p_type_))
select case(p%baseprecv(1)%iprcparm(prec_type_))
case(noprec_)
write(iout,*) 'No preconditioning'
case(diag_)
write(iout,*) 'Diagonal scaling'
case(bjac_)
write(iout,*) 'Block Jacobi with: ',&
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
case(asm_,ras_,ash_,rash_)
& fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
case(as_)
write(iout,*) 'Additive Schwarz with: ',&
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
& fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
write(iout,*) 'Overlap:',&
& p%baseprecv(1)%iprcparm(n_ovr_)
write(iout,*) 'Restriction: ',&
& restrict_names(p%baseprecv(1)%iprcparm(restr_))
& restrict_names(p%baseprecv(1)%iprcparm(sub_restr_))
write(iout,*) 'Prolongation: ',&
& prolong_names(p%baseprecv(1)%iprcparm(prol_))
& prolong_names(p%baseprecv(1)%iprcparm(sub_prol_))
end select
end if
if (size(p%baseprecv)>=2) then
@ -415,12 +411,12 @@ contains
write(iout,*) 'Multilevel aggregation: ', &
& aggr_names(p%baseprecv(ilev)%iprcparm(aggr_alg_))
write(iout,*) 'Smoother: ', &
& smooth_kinds(p%baseprecv(ilev)%iprcparm(smth_kind_))
if (p%baseprecv(ilev)%iprcparm(smth_kind_) /= no_smth_) then
& smooth_kinds(p%baseprecv(ilev)%iprcparm(aggr_kind_))
if (p%baseprecv(ilev)%iprcparm(aggr_kind_) /= no_smooth_) then
write(iout,*) 'Smoothing omega: ', &
& p%baseprecv(ilev)%dprcparm(smooth_omega_)
& p%baseprecv(ilev)%dprcparm(aggr_damp_)
write(iout,*) 'Smoothing position: ',&
& smooth_names(p%baseprecv(ilev)%iprcparm(smth_pos_))
& smooth_names(p%baseprecv(ilev)%iprcparm(smooth_pos_))
end if
write(iout,*) 'Coarse matrix: ',&
& matrix_names(p%baseprecv(ilev)%iprcparm(coarse_mat_))
@ -429,18 +425,18 @@ contains
& sum( p%baseprecv(ilev)%nlaggr(:)),' : ',p%baseprecv(ilev)%nlaggr(:)
end if
write(iout,*) 'Factorization type: ',&
& fact_names(p%baseprecv(ilev)%iprcparm(f_type_))
select case(p%baseprecv(ilev)%iprcparm(f_type_))
case(f_ilu_n_)
write(iout,*) 'Fill level :',p%baseprecv(ilev)%iprcparm(ilu_fill_in_)
case(f_ilu_e_)
& fact_names(p%baseprecv(ilev)%iprcparm(sub_solve_))
select case(p%baseprecv(ilev)%iprcparm(sub_solve_))
case(ilu_n_)
write(iout,*) 'Fill level :',p%baseprecv(ilev)%iprcparm(sub_fill_in_)
case(ilu_t_)
write(iout,*) 'Fill threshold :',p%baseprecv(ilev)%dprcparm(fact_eps_)
case(f_slu_,f_umf_,f_slud_)
case(slu_,umf_,sludist_)
case default
write(iout,*) 'Should never get here!'
end select
write(iout,*) 'Number of Jacobi sweeps: ', &
& (p%baseprecv(ilev)%iprcparm(jac_sweeps_))
& (p%baseprecv(ilev)%iprcparm(smooth_sweeps_))
end if
end do
end if
@ -461,23 +457,23 @@ contains
!!$ if (associated(p%baseprecv)) then
!!$ if (size(p%baseprecv)>=1) then
!!$ write(iout,*) 'Base preconditioner'
!!$ select case(p%baseprecv(1)%iprcparm(p_type_))
!!$ select case(p%baseprecv(1)%iprcparm(prec_type_))
!!$ case(noprec_)
!!$ write(iout,*) 'No preconditioning'
!!$ case(diag_)
!!$ write(iout,*) 'Diagonal scaling'
!!$ case(bjac_)
!!$ write(iout,*) 'Block Jacobi with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ case(asm_,ras_,ash_,rash_)
!!$ & fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
!!$ case(as_,ras_,ash_,rash_)
!!$ write(iout,*) 'Additive Schwarz with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ & fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
!!$ write(iout,*) 'Overlap:',&
!!$ & p%baseprecv(1)%iprcparm(n_ovr_)
!!$ write(iout,*) 'Restriction: ',&
!!$ & restrict_names(p%baseprecv(1)%iprcparm(restr_))
!!$ & restrict_names(p%baseprecv(1)%iprcparm(sub_restr_))
!!$ write(iout,*) 'Prolongation: ',&
!!$ & prolong_names(p%baseprecv(1)%iprcparm(prol_))
!!$ & prolong_names(p%baseprecv(1)%iprcparm(sub_prol_))
!!$ end select
!!$ end if
!!$ if (size(p%baseprecv)>=2) then
@ -490,25 +486,25 @@ contains
!!$ write(iout,*) 'Multilevel aggregation: ', &
!!$ & aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
!!$ write(iout,*) 'Smoother: ', &
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(aggr_kind_))
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(aggr_damp_)
!!$ write(iout,*) 'Smoothing position: ',&
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smooth_pos_))
!!$ write(iout,*) 'Coarse matrix: ',&
!!$ & matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
!!$ write(iout,*) 'Factorization type: ',&
!!$ & fact_names(p%baseprecv(2)%iprcparm(f_type_))
!!$ select case(p%baseprecv(2)%iprcparm(f_type_))
!!$ case(f_ilu_n_)
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
!!$ case(f_ilu_e_)
!!$ & fact_names(p%baseprecv(2)%iprcparm(sub_solve_))
!!$ select case(p%baseprecv(2)%iprcparm(sub_solve_))
!!$ case(ilu_n_)
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(sub_fill_in_)
!!$ case(ilu_t_)
!!$ write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
!!$ case(f_slu_,f_umf_,f_slud_)
!!$ case(slu_,umf_,sludist_)
!!$ case default
!!$ write(iout,*) 'Should never get here!'
!!$ end select
!!$ write(iout,*) 'Number of Jacobi sweeps: ', &
!!$ & (p%baseprecv(2)%iprcparm(jac_sweeps_))
!!$ & (p%baseprecv(2)%iprcparm(smooth_sweeps_))
!!$
!!$ end if
!!$ end if
@ -530,23 +526,23 @@ contains
if (allocated(p%baseprecv)) then
if (size(p%baseprecv)>=1) then
write(iout,*) 'Base preconditioner'
select case(p%baseprecv(1)%iprcparm(p_type_))
select case(p%baseprecv(1)%iprcparm(prec_type_))
case(noprec_)
write(iout,*) 'No preconditioning'
case(diag_)
write(iout,*) 'Diagonal scaling'
case(bjac_)
write(iout,*) 'Block Jacobi with: ',&
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
case(asm_,ras_,ash_,rash_)
& fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
case(as_)
write(iout,*) 'Additive Schwarz with: ',&
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
& fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
write(iout,*) 'Overlap:',&
& p%baseprecv(1)%iprcparm(n_ovr_)
write(iout,*) 'Restriction: ',&
& restrict_names(p%baseprecv(1)%iprcparm(restr_))
& restrict_names(p%baseprecv(1)%iprcparm(sub_restr_))
write(iout,*) 'Prolongation: ',&
& prolong_names(p%baseprecv(1)%iprcparm(prol_))
& prolong_names(p%baseprecv(1)%iprcparm(sub_prol_))
end select
end if
if (size(p%baseprecv)>=2) then
@ -559,11 +555,11 @@ contains
write(iout,*) 'Multilevel aggregation: ', &
& aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
write(iout,*) 'Smoother: ', &
& smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
if (p%baseprecv(2)%iprcparm(smth_kind_) /= no_smth_) then
write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
& smooth_kinds(p%baseprecv(2)%iprcparm(aggr_kind_))
if (p%baseprecv(2)%iprcparm(aggr_kind_) /= no_smooth_) then
write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(aggr_damp_)
write(iout,*) 'Smoothing position: ',&
& smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
& smooth_names(p%baseprecv(2)%iprcparm(smooth_pos_))
end if
write(iout,*) 'Coarse matrix: ',&
@ -573,18 +569,18 @@ contains
& sum( p%baseprecv(2)%nlaggr(:)),' : ',p%baseprecv(2)%nlaggr(:)
endif
write(iout,*) 'Factorization type: ',&
& fact_names(p%baseprecv(2)%iprcparm(f_type_))
select case(p%baseprecv(2)%iprcparm(f_type_))
case(f_ilu_n_)
write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
case(f_ilu_e_)
& fact_names(p%baseprecv(2)%iprcparm(sub_solve_))
select case(p%baseprecv(2)%iprcparm(sub_solve_))
case(ilu_n_)
write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(sub_fill_in_)
case(ilu_t_)
write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
case(f_slu_,f_umf_,f_slud_)
case(slu_,umf_,sludist_)
case default
write(iout,*) 'Should never get here!'
end select
write(iout,*) 'Number of Jacobi sweeps: ', &
& (p%baseprecv(2)%iprcparm(jac_sweeps_))
& (p%baseprecv(2)%iprcparm(smooth_sweeps_))
end if
end if
@ -605,23 +601,23 @@ contains
!!$ if (associated(p%baseprecv)) then
!!$ if (size(p%baseprecv)>=1) then
!!$ write(iout,*) 'Base preconditioner'
!!$ select case(p%baseprecv(1)%iprcparm(p_type_))
!!$ select case(p%baseprecv(1)%iprcparm(prec_type_))
!!$ case(noprec_)
!!$ write(iout,*) 'No preconditioning'
!!$ case(diag_)
!!$ write(iout,*) 'Diagonal scaling'
!!$ case(bjac_)
!!$ write(iout,*) 'Block Jacobi with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ case(asm_,ras_,ash_,rash_)
!!$ & fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
!!$ case(as_,ras_,ash_,rash_)
!!$ write(iout,*) 'Additive Schwarz with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ & fact_names(p%baseprecv(1)%iprcparm(sub_solve_))
!!$ write(iout,*) 'Overlap:',&
!!$ & p%baseprecv(1)%iprcparm(n_ovr_)
!!$ write(iout,*) 'Restriction: ',&
!!$ & restrict_names(p%baseprecv(1)%iprcparm(restr_))
!!$ & restrict_names(p%baseprecv(1)%iprcparm(sub_restr_))
!!$ write(iout,*) 'Prolongation: ',&
!!$ & prolong_names(p%baseprecv(1)%iprcparm(prol_))
!!$ & prolong_names(p%baseprecv(1)%iprcparm(sub_prol_))
!!$ end select
!!$ end if
!!$ if (size(p%baseprecv)>=2) then
@ -634,25 +630,25 @@ contains
!!$ write(iout,*) 'Multilevel aggregation: ', &
!!$ & aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
!!$ write(iout,*) 'Smoother: ', &
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(aggr_kind_))
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(aggr_damp_)
!!$ write(iout,*) 'Smoothing position: ',&
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smooth_pos_))
!!$ write(iout,*) 'Coarse matrix: ',&
!!$ & matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
!!$ write(iout,*) 'Factorization type: ',&
!!$ & fact_names(p%baseprecv(2)%iprcparm(f_type_))
!!$ select case(p%baseprecv(2)%iprcparm(f_type_))
!!$ case(f_ilu_n_)
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
!!$ case(f_ilu_e_)
!!$ & fact_names(p%baseprecv(2)%iprcparm(sub_solve_))
!!$ select case(p%baseprecv(2)%iprcparm(sub_solve_))
!!$ case(ilu_n_)
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(sub_fill_in_)
!!$ case(ilu_t_)
!!$ write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
!!$ case(f_slu_,f_umf_,f_slud_)
!!$ case(slu_,umf_,sludist_)
!!$ case default
!!$ write(iout,*) 'Should never get here!'
!!$ end select
!!$ write(iout,*) 'Number of Jacobi sweeps: ', &
!!$ & (p%baseprecv(2)%iprcparm(jac_sweeps_))
!!$ & (p%baseprecv(2)%iprcparm(smooth_sweeps_))
!!$
!!$ end if
!!$ end if
@ -672,7 +668,7 @@ contains
integer, intent(in) :: ip
logical :: is_legal_base_prec
is_legal_base_prec = ((ip>=noprec_).and.(ip<=rash_))
is_legal_base_prec = ((ip>=noprec_).and.(ip<=max_prec_))
return
end function is_legal_base_prec
function is_legal_n_ovr(ip)
@ -726,7 +722,7 @@ contains
integer, intent(in) :: ip
logical :: is_legal_ml_aggr_kind
is_legal_ml_aggr_kind = ((ip>=loc_aggr_).and.(ip<=max_aggr_))
is_legal_ml_aggr_kind = ((ip>=dec_aggr_).and.(ip<=max_aggr_))
return
end function is_legal_ml_aggr_kind
function is_legal_ml_smooth_pos(ip)
@ -742,7 +738,7 @@ contains
integer, intent(in) :: ip
logical :: is_legal_ml_smth_kind
is_legal_ml_smth_kind = ((ip>=no_smth_).and.(ip<=smth_biz_))
is_legal_ml_smth_kind = ((ip>=no_smooth_).and.(ip<=biz_prol_))
return
end function is_legal_ml_smth_kind
function is_legal_ml_coarse_mat(ip)
@ -750,7 +746,7 @@ contains
integer, intent(in) :: ip
logical :: is_legal_ml_coarse_mat
is_legal_ml_coarse_mat = ((ip>=mat_distr_).and.(ip<=mat_repl_))
is_legal_ml_coarse_mat = ((ip>=distr_mat_).and.(ip<=repl_mat_))
return
end function is_legal_ml_coarse_mat
function is_legal_ml_fact(ip)
@ -758,7 +754,7 @@ contains
integer, intent(in) :: ip
logical :: is_legal_ml_fact
is_legal_ml_fact = ((ip>=f_ilu_n_).and.(ip<=f_slud_))
is_legal_ml_fact = ((ip>=ilu_n_).and.(ip<=sludist_))
return
end function is_legal_ml_fact
function is_legal_ml_lev(ip)
@ -885,13 +881,13 @@ contains
endif
if (allocated(p%iprcparm)) then
if (p%iprcparm(f_type_)==f_slu_) then
if (p%iprcparm(sub_solve_)==slu_) then
call mld_dslu_free(p%iprcparm(slu_ptr_),info)
end if
if (p%iprcparm(f_type_)==f_slud_) then
if (p%iprcparm(sub_solve_)==sludist_) then
call mld_dsludist_free(p%iprcparm(slud_ptr_),info)
end if
if (p%iprcparm(f_type_)==f_umf_) then
if (p%iprcparm(sub_solve_)==umf_) then
call mld_dumf_free(p%iprcparm(umf_symptr_),&
& p%iprcparm(umf_numptr_),info)
end if
@ -968,10 +964,10 @@ contains
endif
if (allocated(p%iprcparm)) then
if (p%iprcparm(f_type_)==f_slu_) then
if (p%iprcparm(sub_solve_)==slu_) then
call mld_zslu_free(p%iprcparm(slu_ptr_),info)
end if
if (p%iprcparm(f_type_)==f_umf_) then
if (p%iprcparm(sub_solve_)==umf_) then
call mld_zumf_free(p%iprcparm(umf_symptr_),&
& p%iprcparm(umf_numptr_),info)
end if
@ -1005,14 +1001,8 @@ contains
pr_to_str='DIAG'
case(bjac_)
pr_to_str='BJAC'
case(asm_)
pr_to_str='ASM'
case(ash_)
pr_to_str='ASM'
case(ras_)
pr_to_str='ASM'
case(rash_)
pr_to_str='ASM'
case(as_)
pr_to_str='AS'
end select
end function pr_to_str

122
psb_zprecinit.f90
Unescape Escape View File

@ -65,13 +65,13 @@ subroutine psb_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = noprec_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = noprec_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = f_none_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('DIAG')
nlev_ = 1
@ -80,13 +80,13 @@ subroutine psb_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(p_type_) = diag_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = diag_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = f_none_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('BJAC')
nlev_ = 1
@ -96,14 +96,14 @@ subroutine psb_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('ASM','AS')
nlev_ = 1
@ -112,14 +112,14 @@ subroutine psb_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(p_type_) = asm_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = as_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
case ('MLD', 'ML')
@ -137,55 +137,55 @@ subroutine psb_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(p_type_) = asm_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = as_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(p_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml_prec_
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = loc_aggr_
p%baseprecv(ilev_)%iprcparm(smth_kind_) = smth_omg_
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = mat_distr_
p%baseprecv(ilev_)%iprcparm(smth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(om_choice_) = lib_choice_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = 4.d0/3.d0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = dec_aggr_
p%baseprecv(ilev_)%iprcparm(aggr_kind_) = tent_prol
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = distr_mat_
p%baseprecv(ilev_)%iprcparm(smooth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(aggr_eig_) = max_norm_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = ilu_n_
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 1
p%baseprecv(ilev_)%dprcparm(aggr_damp_) = 4.d0/3.d0
end do
ilev_ = nlev_
if (info == 0) call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(p_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(prec_type_) = bjac_
p%baseprecv(ilev_)%iprcparm(sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(n_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml_prec_
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = loc_aggr_
p%baseprecv(ilev_)%iprcparm(smth_kind_) = smth_omg_
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = mat_distr_
p%baseprecv(ilev_)%iprcparm(smth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(om_choice_) = lib_choice_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_umf_
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 4
p%baseprecv(ilev_)%dprcparm(smooth_omega_) = 4.d0/3.d0
p%baseprecv(ilev_)%iprcparm(ml_type_) = mult_ml
p%baseprecv(ilev_)%iprcparm(aggr_alg_) = dec_aggr_
p%baseprecv(ilev_)%iprcparm(aggr_kind_) = tent_prol
p%baseprecv(ilev_)%iprcparm(coarse_mat_) = distr_mat_
p%baseprecv(ilev_)%iprcparm(smooth_pos_) = post_smooth_
p%baseprecv(ilev_)%iprcparm(aggr_eig_) = max_norm_
p%baseprecv(ilev_)%iprcparm(sub_solve_) = umf_
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = 4
p%baseprecv(ilev_)%dprcparm(aggr_damp_) = 4.d0/3.d0
case default
write(0,*) 'Unknown preconditioner type request "',ptype,'"'

117
psb_zprecset.f90
Unescape Escape View File

@ -50,12 +50,6 @@ subroutine psb_zprecseti(p,what,val,info,ilev)
info = 0
if (present(ilev)) then
ilev_ = ilev
else
ilev_ = 1
end if
if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
@ -63,6 +57,12 @@ subroutine psb_zprecseti(p,what,val,info,ilev)
endif
nlev_ = size(p%baseprecv)
if (present(ilev)) then
ilev_ = ilev
else
ilev_ = 1
end if
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
info = -1
@ -75,25 +75,90 @@ subroutine psb_zprecseti(p,what,val,info,ilev)
endif
if (present(ilev)) then
if (ilev_ == 1) then
! Rules for fine level are slightly different.
select case(what)
case(prec_type_,sub_solve_,sub_restr_,sub_prol_,sub_ren_,n_ovr_,sub_fill_in_,smooth_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
else if (ilev_ > 1) then
select case(what)
case(prec_type_,sub_solve_,sub_restr_,sub_prol_,sub_ren_,n_ovr_,sub_fill_in_,&
& smooth_sweeps_,ml_type_,aggr_alg_,aggr_kind_,coarse_mat_,&
& smooth_pos_,aggr_eig_)
p%baseprecv(ilev_)%iprcparm(what) = val
case(coarse_solve_)
if (ilev_ /= nlev_) then
write(0,*) 'Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(sub_solve_) = val
case(coarse_sweeps_)
if (ilev_ /= nlev_) then
write(0,*) 'Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(smooth_sweeps_) = val
case(coarse_fill_in_)
if (ilev_ /= nlev_) then
write(0,*) 'Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(sub_fill_in_) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
endif
else if (.not.present(ilev)) then
select case(what)
case(prec_type_,sub_solve_,sub_restr_,sub_prol_,sub_ren_,n_ovr_,sub_fill_in_,&
& smooth_sweeps_,ml_type_,aggr_alg_,aggr_kind_,coarse_mat_,&
& smooth_pos_,aggr_eig_)
do ilev_=1,nlev_-1
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
end do
case(coarse_solve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(nlev_)%iprcparm(sub_solve_) = val
case(coarse_sweeps_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(nlev_)%iprcparm(smooth_sweeps_) = val
case(coarse_fill_in_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner'
info = -1
return
endif
p%baseprecv(nlev_)%iprcparm(sub_fill_in_) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
if (ilev_ == 1) then
! Rules for fine level are slightly different.
select case(what)
case(p_type_,f_type_,restr_,prol_,iren_,n_ovr_,ilu_fill_in_,jac_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
else if (ilev_ > 1) then
select case(what)
case(p_type_,f_type_,restr_,prol_,iren_,n_ovr_,ilu_fill_in_,jac_sweeps_,&
& ml_type_,aggr_alg_,smth_kind_,coarse_mat_,smth_pos_,om_choice_)
p%baseprecv(ilev_)%iprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
endif
end subroutine psb_zprecseti
@ -141,14 +206,14 @@ subroutine psb_zprecsetd(p,what,val,info,ilev)
! Rules for fine level are slightly different.
select case(what)
! Right now we don't have any at base level. Will change when
! we implement F_ILU_E_
! we implement ilu_t_
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'
info = -2
end select
else if (ilev_ > 1) then
select case(what)
case(smooth_omega_)
case(aggr_damp_)
p%baseprecv(ilev_)%dprcparm(what) = val
case default
write(0,*) 'Error: trying to call PRECSET with an invalid WHAT'

Write Preview
Loading…
Cancel
Save