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

Name changes for constants.

Browse Source
This commit is contained in:
Salvatore Filippone
2007-05-28 14:34:10 +00:00
parent dc68acd075
commit 8293656ef1
23 changed files with 707 additions and 589 deletions
Download Patch File Download Diff File Expand all files Collapse all files
mld_daggrmat_asb.F90
+26 -26
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_)
!
!
mld_dasmat_bld.f90
+1 -1
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
!
mld_dbaseprec_aply.f90
+12 -13
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)
mld_dbaseprec_bld.f90
+11 -11
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
mld_dbjac_aply.f90
+18 -18
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
mld_dbjac_bld.f90
+23 -23
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
mld_dmlprec_aply.f90
+33 -33
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
mld_dmlprec_bld.f90
+12 -12
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)
mld_dsp_renum.f90
+2 -2
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)
mld_zaggrmat_asb.F90
+26 -26
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_)
!
!
mld_zasmat_bld.f90
+1 -1
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
!
mld_zbaseprec_aply.f90
+12 -13
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)
mld_zbaseprec_bld.f90
+11 -11
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
mld_zbjac_aply.f90
+17 -17
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
mld_zbjac_bld.f90
+23 -23
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
mld_zmlprec_aply.f90
+33 -33
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
mld_zmlprec_bld.f90
+12 -12
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)
mld_zsp_renum.f90
+2 -2
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
psb_dprecinit.f90
+74 -74
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,'"'
psb_dprecset.f90
+91 -26
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'
psb_prec_type.f90
+115 -125
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
psb_zprecinit.f90
+61 -61
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,'"'
psb_zprecset.f90
+91 -26
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'