From f92e7157cb599a2a80e83ba303b739e4711a5285 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 3 Nov 2010 19:41:14 +0000 Subject: [PATCH] mld2p4-2: Makefile mld_zcoarse_bld.f90 mld_zmlprec_bld.f90 mld_zslu_bld.f90 mld_zumf_bld.f90 Further advance on double complex. --- mlprec/Makefile | 1 + mlprec/mld_zcoarse_bld.f90 | 12 ++-- mlprec/mld_zmlprec_bld.f90 | 131 +++++++++++++++++++++++++++++++------ mlprec/mld_zslu_bld.f90 | 33 +++++----- mlprec/mld_zumf_bld.f90 | 38 +++++------ 5 files changed, 155 insertions(+), 60 deletions(-) diff --git a/mlprec/Makefile b/mlprec/Makefile index 6932b36f..b131bd4c 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -27,6 +27,7 @@ INNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_dslu_bld.o mld_dumf_bld.o \ mld_ccoarse_bld.o mld_cmlprec_bld.o mld_cslu_bld.o mld_cumf_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_cmlprec_aply.o mld_cslud_bld.o mld_caggrmat_asb.o \ + mld_zcoarse_bld.o mld_zmlprec_bld.o mld_zslu_bld.o mld_zumf_bld.o \ $(MPFOBJS) # diff --git a/mlprec/mld_zcoarse_bld.f90 b/mlprec/mld_zcoarse_bld.f90 index 14f3337c..6033054f 100644 --- a/mlprec/mld_zcoarse_bld.f90 +++ b/mlprec/mld_zcoarse_bld.f90 @@ -79,11 +79,9 @@ subroutine mld_zcoarse_bld(a,desc_a,p,info) integer, intent(out) :: info ! Local variables - type(psb_desc_type) :: desc_ac - type(psb_zspmat_type) :: ac - character(len=20) :: name - integer :: ictxt, np, me, err_act - integer, allocatable :: ilaggr(:), nlaggr(:) + character(len=20) :: name + integer :: ictxt, np, me, err_act + integer, allocatable :: ilaggr(:), nlaggr(:) name='mld_zcoarse_bld' if (psb_get_errstatus().ne.0) return @@ -125,7 +123,8 @@ subroutine mld_zcoarse_bld(a,desc_a,p,info) ! call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),& & a,desc_a,ilaggr,nlaggr,info) - if(info /= psb_success_) then + + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') goto 9999 end if @@ -136,6 +135,7 @@ subroutine mld_zcoarse_bld(a,desc_a,p,info) ! algorithm specified by p%iprcparm(mld_aggr_kind_) ! call mld_aggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') goto 9999 diff --git a/mlprec/mld_zmlprec_bld.f90 b/mlprec/mld_zmlprec_bld.f90 index 02cf8c26..ed0e3b98 100644 --- a/mlprec/mld_zmlprec_bld.f90 +++ b/mlprec/mld_zmlprec_bld.f90 @@ -69,6 +69,10 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info) use psb_sparse_mod use mld_inner_mod, mld_protect_name => mld_zmlprec_bld use mld_prec_mod + use mld_z_jac_smoother + use mld_z_as_smoother + use mld_z_diag_solver + use mld_z_ilu_solver Implicit None @@ -219,7 +223,8 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info) & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Init upper level preconditioner') + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Init upper level preconditioner') goto 9999 endif @@ -250,7 +255,8 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info) end if allocate(t_prec%precv(newsz),stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='prec reallocation') + call psb_errpush(psb_err_from_subroutine_,name,& + & a_err='prec reallocation') goto 9999 endif do i=1,newsz-1 @@ -303,14 +309,72 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info) call mld_check_def(p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),& & 'Eps',dzero,is_legal_fact_thrs) end select - call mld_check_def(p%precv(i)%prec%iprcparm(mld_smoother_sweeps_),& + call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_),& & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_pre_),& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + call mld_check_def(p%precv(i)%iprcparm(mld_smoother_sweeps_post_),& + & 'Jacobi sweeps',1,is_legal_jac_sweeps) + + ! + ! Test version for beginning of OO stuff. + ! + if (allocated(p%precv(i)%sm)) then + call p%precv(i)%sm%free(info) + if (info == psb_success_) deallocate(p%precv(i)%sm,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif + end if + select case (p%precv(i)%prec%iprcparm(mld_smoother_type_)) + case(mld_bjac_, mld_jac_) + allocate(mld_z_jac_smoother_type :: p%precv(i)%sm, stat=info) + case(mld_as_) + allocate(mld_z_as_smoother_type :: p%precv(i)%sm, stat=info) + case default + info = -1 + end select + if (info /= psb_success_) then + write(0,*) ' Smoother allocation error',info,& + & p%precv(i)%prec%iprcparm(mld_smoother_type_) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif + call p%precv(i)%sm%set(mld_sub_restr_,p%precv(i)%prec%iprcparm(mld_sub_restr_),info) + call p%precv(i)%sm%set(mld_sub_prol_,p%precv(i)%prec%iprcparm(mld_sub_prol_),info) + call p%precv(i)%sm%set(mld_sub_ovr_,p%precv(i)%prec%iprcparm(mld_sub_ovr_),info) + + select case (p%precv(i)%prec%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + allocate(mld_z_ilu_solver_type :: p%precv(i)%sm%sv, stat=info) + if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_solve_,& + & p%precv(i)%prec%iprcparm(mld_sub_solve_),info) + if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_fillin_,& + & p%precv(i)%prec%iprcparm(mld_sub_fillin_),info) + if (info == psb_success_) call p%precv(i)%sm%sv%set(mld_sub_iluthrs_,& + & p%precv(i)%prec%rprcparm(mld_sub_iluthrs_),info) + case(mld_diag_scale_) + allocate(mld_z_diag_solver_type :: p%precv(i)%sm%sv, stat=info) + case default + info = -1 + end select + + if (info /= psb_success_) then + write(0,*) ' Solver allocation error',info,& + & p%precv(i)%prec%iprcparm(mld_sub_solve_) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif - call mld_baseprec_bld(p%precv(i)%base_a,p%precv(i)%base_desc,& - & p%precv(i)%prec,info) + call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,'F',info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='One level preconditioner build.') + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') goto 9999 endif @@ -336,19 +400,19 @@ contains subroutine init_baseprec_av(p,info) type(mld_zbaseprec_type), intent(inout) :: p integer :: info - if (allocated(p%av)) then - if (size(p%av) /= mld_max_avsz_) then - deallocate(p%av,stat=info) - if (info /= psb_success_) return - endif - end if - if (.not.(allocated(p%av))) then - allocate(p%av(mld_max_avsz_),stat=info) - if (info /= psb_success_) return - end if - do k=1,size(p%av) - call psb_nullify_sp(p%av(k)) - end do +!!$ if (allocated(p%av)) then +!!$ if (size(p%av) /= mld_max_avsz_) then +!!$ deallocate(p%av,stat=info) +!!$ if (info /= psb_success_) return +!!$ endif +!!$ end if +!!$ if (.not.(allocated(p%av))) then +!!$ allocate(p%av(mld_max_avsz_),stat=info) +!!$ if (info /= psb_success_) return +!!$ end if +!!$ do k=1,size(p%av) +!!$ call psb_nullify_sp(p%av(k)) +!!$ end do end subroutine init_baseprec_av @@ -360,6 +424,35 @@ contains ! val = prec%iprcparm(mld_coarse_solve_) select case (val) + case(mld_jac_) + + if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then + if (me == 0) write(debug_unit,*)& + & 'Warning: inconsistent coarse level specification.' + if (me == 0) write(debug_unit,*)& + & ' Resetting according to the value specified for mld_coarse_solve_.' + prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ + end if + prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ + + case(mld_bjac_) + + if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& + & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then + if (me == 0) write(debug_unit,*)& + & 'Warning: inconsistent coarse level specification.' + if (me == 0) write(debug_unit,*)& + & ' Resetting according to the value specified for mld_coarse_solve_.' +!!$#if defined(HAVE_UMF_) +!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ +!!$#elif defined(HAVE_SLU_) +!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ +!!$#else + prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ +!!$#endif + end if + prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ + case(mld_umf_, mld_slu_) if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then diff --git a/mlprec/mld_zslu_bld.f90 b/mlprec/mld_zslu_bld.f90 index c69a7655..4a8d1c84 100644 --- a/mlprec/mld_zslu_bld.f90 +++ b/mlprec/mld_zslu_bld.f90 @@ -83,8 +83,8 @@ subroutine mld_zslu_bld(a,desc_a,p,info) integer, intent(out) :: info ! Local variables - integer :: nzt,ictxt,me,np,err_act - character(len=20) :: name, ch_err + integer :: ictxt,me,np,err_act + character(len=20) :: name, ch_err if(psb_get_errstatus().ne.0) return info=psb_success_ @@ -94,25 +94,28 @@ subroutine mld_zslu_bld(a,desc_a,p,info) ictxt = psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) + - if (psb_toupper(a%fida) /= 'CSR') then - info=psb_err_unsupported_format_ - call psb_errpush(info,name,a_err=a%fida) - goto 9999 - endif - - nzt = psb_sp_get_nnzeros(a) ! ! Compute the LU factorization ! - call mld_zslu_fact(a%m,nzt,& - & a%aspk,a%ia2,a%ia1,p%iprcparm(mld_slu_ptr_),info) + select type(aa=>a%a) + type is (psb_z_csr_sparse_mat) + call mld_zslu_fact(aa%get_nrows(),aa%get_nzeros(),& + & aa%val,aa%ja,aa%irp,p%iprcparm(mld_slu_ptr_),info) - if (info /= psb_success_) then - ch_err='mld_slu_fact' - call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + if (info /= psb_success_) then + ch_err='mld_slu_fact' + call psb_errpush(4110,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + + class default + info=psb_err_unsupported_format_ + ch_err=a%get_fmt() + call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end select call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_zumf_bld.f90 b/mlprec/mld_zumf_bld.f90 index 27ecea4c..5be0fbec 100644 --- a/mlprec/mld_zumf_bld.f90 +++ b/mlprec/mld_zumf_bld.f90 @@ -89,9 +89,8 @@ subroutine mld_zumf_bld(a,desc_a,p,info) integer, intent(out) :: info ! Local variables - integer :: nzt,ictxt,me,np,err_act - integer :: i_err(5) - character(len=20) :: name + integer :: ictxt,me,np,err_act + character(len=20) :: name, ch_err info=psb_success_ name='mld_zumf_bld' @@ -99,27 +98,26 @@ subroutine mld_zumf_bld(a,desc_a,p,info) ictxt = psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) - if (psb_toupper(a%fida) /= 'CSC') then - info=psb_err_unsupported_format_ - call psb_errpush(info,name,a_err=a%fida) - goto 9999 - endif - - nzt = psb_sp_get_nnzeros(a) - ! ! Compute the LU factorization ! - call mld_zumf_fact(a%m,nzt,& - & a%aspk,a%ia1,a%ia2,& - & p%iprcparm(mld_umf_symptr_),p%iprcparm(mld_umf_numptr_),info) - - if (info /= psb_success_) then - i_err(1) = info - info=4110 - call psb_errpush(info,name,a_err='mld_umf_fact',i_err=i_err) + select type(aa=>a%a) +!!$ type is (psb_z_csc_sparse_mat) +!!$ call mld_zumf_fact(aa%m,aa%get_nzeros(),& +!!$ & aa%val,aa%ia,aa%icp,& +!!$ & p%iprcparm(mld_umf_symptr_),p%iprcparm(mld_umf_numptr_),info) +!!$ +!!$ if (info /= psb_success_) then +!!$ info=4110 +!!$ call psb_errpush(info,name,a_err='mld_umf_fact',i_err=(/info,0,0,0,0/)) +!!$ goto 9999 +!!$ end if + class default + info=psb_err_unsupported_format_ + ch_err = aa%get_fmt() + call psb_errpush(info,name,a_err=ch_err) goto 9999 - end if + end select call psb_erractionrestore(err_act) return