diff --git a/amgprec/amg_c_onelev_mod.f90 b/amgprec/amg_c_onelev_mod.f90 index ab044e74..aab615d1 100644 --- a/amgprec/amg_c_onelev_mod.f90 +++ b/amgprec/amg_c_onelev_mod.f90 @@ -252,9 +252,7 @@ module amg_c_onelev_mod & c_base_onelev_free_wrk interface - subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - import :: psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lcspmat_type, psb_lpk_ - import :: amg_c_onelev_type + module subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) implicit none class(amg_c_onelev_type), intent(inout), target :: lv type(psb_cspmat_type), intent(in) :: a @@ -266,10 +264,7 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv) - import :: psb_c_base_sparse_mat, psb_c_base_vect_type, & - & psb_i_base_vect_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv) implicit none class(amg_c_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info @@ -281,10 +276,7 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) Implicit None ! Arguments class(amg_c_onelev_type), intent(in) :: lv @@ -297,10 +289,8 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity, prefix,global) Implicit None ! Arguments class(amg_c_onelev_type), intent(in) :: lv @@ -314,10 +304,7 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold) - import :: amg_c_onelev_type, psb_c_base_vect_type, psb_spk_, & - & psb_c_base_sparse_mat, psb_ipk_, psb_i_base_vect_type - ! Arguments + module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold) class(amg_c_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold @@ -327,48 +314,32 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_free(lv,info) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_free(lv,info) implicit none - class(amg_c_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_c_base_onelev_free end interface interface - subroutine amg_c_base_onelev_free_smoothers(lv,info) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_free_smoothers(lv,info) implicit none - class(amg_c_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_c_base_onelev_free_smoothers end interface interface - subroutine amg_c_base_onelev_check(lv,info) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_check(lv,info) Implicit None - ! Arguments class(amg_c_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_c_base_onelev_check end interface interface - subroutine amg_c_base_onelev_setsm(lv,val,info,pos) - import :: psb_spk_, amg_c_onelev_type, amg_c_base_smoother_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_setsm(lv,val,info,pos) Implicit None - - ! Arguments class(amg_c_onelev_type), target, intent(inout) :: lv class(amg_c_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -377,12 +348,8 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_setsv(lv,val,info,pos) - import :: psb_spk_, amg_c_onelev_type, amg_c_base_solver_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_setsv(lv,val,info,pos) Implicit None - - ! Arguments class(amg_c_onelev_type), target, intent(inout) :: lv class(amg_c_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -391,12 +358,8 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_setag(lv,val,info,pos) - import :: psb_spk_, amg_c_onelev_type, amg_c_base_aggregator_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_setag(lv,val,info,pos) Implicit None - - ! Arguments class(amg_c_onelev_type), target, intent(inout) :: lv class(amg_c_base_aggregator_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -405,13 +368,8 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx) Implicit None - - ! Arguments class(amg_c_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -422,12 +380,8 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx) Implicit None - ! Arguments class(amg_c_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what character(len=*), intent(in) :: val @@ -438,12 +392,8 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx) Implicit None - class(amg_c_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val @@ -454,11 +404,8 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& + module subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& & solver,tprol,global_num) - import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, amg_c_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type implicit none class(amg_c_onelev_type), intent(in) :: lv integer(psb_ipk_), intent(in) :: level @@ -469,8 +416,7 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - import + module subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) implicit none class(amg_c_onelev_type), target, intent(inout) :: lv complex(psb_spk_), intent(in) :: alpha, beta @@ -479,8 +425,8 @@ module amg_c_onelev_mod integer(psb_ipk_), intent(out) :: info complex(psb_spk_), optional :: work(:) end subroutine amg_c_base_onelev_map_rstr_a - subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty) - import + module subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) implicit none class(amg_c_onelev_type), target, intent(inout) :: lv complex(psb_spk_), intent(in) :: alpha, beta @@ -492,8 +438,7 @@ module amg_c_onelev_mod end interface interface - subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - import + module subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) implicit none class(amg_c_onelev_type), target, intent(inout) :: lv complex(psb_spk_), intent(in) :: alpha, beta @@ -503,8 +448,8 @@ module amg_c_onelev_mod complex(psb_spk_), optional :: work(:) end subroutine amg_c_base_onelev_map_prol_a - subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - import + module subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,& + & work,vtx,vty) implicit none class(amg_c_onelev_type), target, intent(inout) :: lv complex(psb_spk_), intent(in) :: alpha, beta @@ -515,6 +460,118 @@ module amg_c_onelev_mod end subroutine amg_c_base_onelev_map_prol_v end interface + interface + module subroutine c_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_onelev_move_alloc + end interface + + interface + module subroutine c_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + end subroutine c_base_onelev_allocate_wrk + end interface + + interface + module subroutine c_base_onelev_free_wrk(lv,info) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + end subroutine c_base_onelev_free_wrk + end interface + + interface + module subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + end subroutine c_wrk_alloc + end interface + + interface + module subroutine c_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_c_base_vect_type), intent(in), optional :: vmold + end subroutine c_inner_do_wrk_alloc + end interface + + interface + module subroutine c_wrk_free(wk,info) + Implicit None + ! Arguments + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + end subroutine c_wrk_free + end interface + + interface + module subroutine c_wrk_clone(wk,wkout,info) + Implicit None + ! Arguments + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + end subroutine c_wrk_clone + end interface + + interface + module subroutine c_wrk_move_alloc(wk, b,info) + implicit none + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + end subroutine c_wrk_move_alloc + end interface + + interface + module subroutine c_wrk_cnv(wk,info,vmold) + Implicit None + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + end subroutine c_wrk_cnv + end interface + + interface + module function c_wrk_sizeof(wk) result(val) + implicit none + class(amg_cmlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + end function c_wrk_sizeof + end interface + + interface + module subroutine c_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_c_remap_data_type), target, intent(inout) :: rmp + class(amg_c_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine c_remap_data_clone + end interface + + interface + module subroutine c_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_c_remap_data_type), target, intent(inout) :: rmp + class(amg_c_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine c_remap_move_alloc + end interface + + contains ! ! Function returning the size of the amg_prec_type data structure @@ -682,37 +739,6 @@ contains end subroutine c_base_onelev_clone - subroutine c_base_onelev_move_alloc(lv, b,info) - use psb_base_mod - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - b%parms = lv%parms - b%szratio = lv%szratio - if (associated(lv%sm2,lv%sm2a)) then - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm2a - else - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm - end if - - call move_alloc(lv%aggr,b%aggr) - if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) - if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) - if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) - b%base_a => lv%base_a - b%base_desc => lv%base_desc - - end subroutine c_base_onelev_move_alloc - - function c_base_onelev_get_wrksize(lv) result(val) implicit none class(amg_c_onelev_type), intent(inout) :: lv @@ -750,275 +776,5 @@ contains end function c_base_onelev_get_wrksize - subroutine c_base_onelev_allocate_wrk(lv,info,vmold) - use psb_base_mod - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: nwv, i - info = psb_success_ - nwv = lv%get_wrksz() - if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) -!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() - if (info == 0) then - if (lv%remap_data%desc_ac_pre_remap%is_asb()) then - ! - ! Need to fix this, we need two different allocations - ! - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& - & desc2=lv%remap_data%desc_ac_pre_remap) - else - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) - end if - end if - - end subroutine c_base_onelev_allocate_wrk - - - subroutine c_base_onelev_free_wrk(lv,info) - use psb_base_mod - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: nwv,i - info = psb_success_ - - if (allocated(lv%wrk)) then - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) - end if - end subroutine c_base_onelev_free_wrk - - subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_cmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type), intent(in), optional :: vmold - type(psb_desc_type), intent(in), optional :: desc2 - ! - integer(psb_ipk_) :: i - - info = psb_success_ - call wk%free(info) -!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& -!!$ & present(desc2),desc%is_valid() - - allocate(wk%wv(nwv),stat=info) - if (present(desc2).and.(desc%is_valid())) then -!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() - if (desc2%get_local_cols()>desc%get_local_cols()) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - else if (present(desc2)) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else if (desc%is_valid()) then - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - - contains - subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold) - class(amg_cmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - class(psb_c_base_vect_type), intent(in), optional :: vmold - - integer(psb_ipk_) :: i - - call psb_geasb(wk%vx2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vy2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vtx,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vty,desc,info,& - & scratch=.true.,mold=vmold) - do i=1,nwv - call psb_geasb(wk%wv(i),desc,info,& - & scratch=.true.,mold=vmold) - end do - end subroutine inner_do_wrk_alloc - end subroutine c_wrk_alloc - - subroutine c_wrk_free(wk,info) - - Implicit None - - ! Arguments - class(amg_cmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - if (allocated(wk%tx)) deallocate(wk%tx, stat=info) - if (allocated(wk%ty)) deallocate(wk%ty, stat=info) - if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) - if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) - call wk%vtx%free(info) - call wk%vty%free(info) - call wk%vx2l%free(info) - call wk%vy2l%free(info) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%free(info) - end do - deallocate(wk%wv, stat=info) - end if - - end subroutine c_wrk_free - - subroutine c_wrk_clone(wk,wkout,info) - use psb_base_mod - Implicit None - - ! Arguments - class(amg_cmlprec_wrk_type), target, intent(inout) :: wk - class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - call psb_safe_ab_cpy(wk%tx,wkout%tx,info) - call psb_safe_ab_cpy(wk%ty,wkout%ty,info) - call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) - call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) - call wk%vtx%clone(wkout%vtx,info) - call wk%vty%clone(wkout%vty,info) - call wk%vx2l%clone(wkout%vx2l,info) - call wk%vy2l%clone(wkout%vy2l,info) - if (allocated(wkout%wv)) then - do i=1,size(wkout%wv) - call wkout%wv(i)%free(info) - end do - deallocate( wkout%wv) - end if - allocate(wkout%wv(size(wk%wv)),stat=info) - do i=1,size(wk%wv) - call wk%wv(i)%clone(wkout%wv(i),info) - end do - return - - end subroutine c_wrk_clone - - subroutine c_wrk_move_alloc(wk, b,info) - implicit none - class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - call move_alloc(wk%tx,b%tx) - call move_alloc(wk%ty,b%ty) - call move_alloc(wk%x2l,b%x2l) - call move_alloc(wk%y2l,b%y2l) - ! - ! Should define V%move_alloc.... - call move_alloc(wk%vtx%v,b%vtx%v) - call move_alloc(wk%vty%v,b%vty%v) - call move_alloc(wk%vx2l%v,b%vx2l%v) - call move_alloc(wk%vy2l%v,b%vy2l%v) - call move_alloc(wk%wv,b%wv) - - end subroutine c_wrk_move_alloc - - subroutine c_wrk_cnv(wk,info,vmold) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_cmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: i - - info = psb_success_ - if (present(vmold)) then - call wk%vtx%cnv(vmold) - call wk%vty%cnv(vmold) - call wk%vx2l%cnv(vmold) - call wk%vy2l%cnv(vmold) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%cnv(vmold) - end do - end if - end if - end subroutine c_wrk_cnv - - function c_wrk_sizeof(wk) result(val) - use psb_realloc_mod - implicit none - class(amg_cmlprec_wrk_type), intent(in) :: wk - integer(psb_epk_) :: val - integer :: i - val = 0 - val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%tx) - val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%ty) - val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%x2l) - val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%y2l) - val = val + wk%vtx%sizeof() - val = val + wk%vty%sizeof() - val = val + wk%vx2l%sizeof() - val = val + wk%vy2l%sizeof() - if (allocated(wk%wv)) then - do i=1, size(wk%wv) - val = val + wk%wv(i)%sizeof() - end do - end if - end function c_wrk_sizeof - - subroutine c_remap_data_clone(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_c_remap_data_type), target, intent(inout) :: rmp - class(amg_c_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) - call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) - end subroutine c_remap_data_clone - - subroutine c_remap_move_alloc(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_c_remap_data_type), target, intent(inout) :: rmp - class(amg_c_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call move_alloc(rmp%isrc,remap_out%isrc) - call move_alloc(rmp%nrsrc,remap_out%nrsrc) - call move_alloc(rmp%naggr,remap_out%naggr) - end subroutine c_remap_move_alloc end module amg_c_onelev_mod diff --git a/amgprec/amg_d_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index 7cc43b7f..23e45b12 100644 --- a/amgprec/amg_d_onelev_mod.f90 +++ b/amgprec/amg_d_onelev_mod.f90 @@ -253,9 +253,7 @@ module amg_d_onelev_mod & d_base_onelev_free_wrk interface - subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_ldspmat_type, psb_lpk_ - import :: amg_d_onelev_type + module subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) implicit none class(amg_d_onelev_type), intent(inout), target :: lv type(psb_dspmat_type), intent(in) :: a @@ -267,10 +265,7 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv) - import :: psb_d_base_sparse_mat, psb_d_base_vect_type, & - & psb_i_base_vect_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv) implicit none class(amg_d_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info @@ -282,10 +277,7 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) Implicit None ! Arguments class(amg_d_onelev_type), intent(in) :: lv @@ -298,10 +290,8 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity, prefix,global) Implicit None ! Arguments class(amg_d_onelev_type), intent(in) :: lv @@ -315,10 +305,7 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold) - import :: amg_d_onelev_type, psb_d_base_vect_type, psb_dpk_, & - & psb_d_base_sparse_mat, psb_ipk_, psb_i_base_vect_type - ! Arguments + module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold) class(amg_d_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: amold @@ -328,48 +315,32 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_free(lv,info) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_free(lv,info) implicit none - class(amg_d_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_d_base_onelev_free end interface interface - subroutine amg_d_base_onelev_free_smoothers(lv,info) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_free_smoothers(lv,info) implicit none - class(amg_d_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_d_base_onelev_free_smoothers end interface interface - subroutine amg_d_base_onelev_check(lv,info) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_check(lv,info) Implicit None - ! Arguments class(amg_d_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_d_base_onelev_check end interface interface - subroutine amg_d_base_onelev_setsm(lv,val,info,pos) - import :: psb_dpk_, amg_d_onelev_type, amg_d_base_smoother_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_setsm(lv,val,info,pos) Implicit None - - ! Arguments class(amg_d_onelev_type), target, intent(inout) :: lv class(amg_d_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -378,12 +349,8 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_setsv(lv,val,info,pos) - import :: psb_dpk_, amg_d_onelev_type, amg_d_base_solver_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_setsv(lv,val,info,pos) Implicit None - - ! Arguments class(amg_d_onelev_type), target, intent(inout) :: lv class(amg_d_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -392,12 +359,8 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_setag(lv,val,info,pos) - import :: psb_dpk_, amg_d_onelev_type, amg_d_base_aggregator_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_setag(lv,val,info,pos) Implicit None - - ! Arguments class(amg_d_onelev_type), target, intent(inout) :: lv class(amg_d_base_aggregator_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -406,13 +369,8 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) Implicit None - - ! Arguments class(amg_d_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -423,12 +381,8 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) Implicit None - ! Arguments class(amg_d_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what character(len=*), intent(in) :: val @@ -439,12 +393,8 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx) Implicit None - class(amg_d_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val @@ -455,11 +405,8 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& + module subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& & solver,tprol,global_num) - import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type implicit none class(amg_d_onelev_type), intent(in) :: lv integer(psb_ipk_), intent(in) :: level @@ -470,8 +417,7 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - import + module subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) implicit none class(amg_d_onelev_type), target, intent(inout) :: lv real(psb_dpk_), intent(in) :: alpha, beta @@ -480,8 +426,8 @@ module amg_d_onelev_mod integer(psb_ipk_), intent(out) :: info real(psb_dpk_), optional :: work(:) end subroutine amg_d_base_onelev_map_rstr_a - subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty) - import + module subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) implicit none class(amg_d_onelev_type), target, intent(inout) :: lv real(psb_dpk_), intent(in) :: alpha, beta @@ -493,8 +439,7 @@ module amg_d_onelev_mod end interface interface - subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - import + module subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) implicit none class(amg_d_onelev_type), target, intent(inout) :: lv real(psb_dpk_), intent(in) :: alpha, beta @@ -504,8 +449,8 @@ module amg_d_onelev_mod real(psb_dpk_), optional :: work(:) end subroutine amg_d_base_onelev_map_prol_a - subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - import + module subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,& + & work,vtx,vty) implicit none class(amg_d_onelev_type), target, intent(inout) :: lv real(psb_dpk_), intent(in) :: alpha, beta @@ -516,6 +461,118 @@ module amg_d_onelev_mod end subroutine amg_d_base_onelev_map_prol_v end interface + interface + module subroutine d_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_onelev_move_alloc + end interface + + interface + module subroutine d_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + end subroutine d_base_onelev_allocate_wrk + end interface + + interface + module subroutine d_base_onelev_free_wrk(lv,info) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + end subroutine d_base_onelev_free_wrk + end interface + + interface + module subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + end subroutine d_wrk_alloc + end interface + + interface + module subroutine d_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_d_base_vect_type), intent(in), optional :: vmold + end subroutine d_inner_do_wrk_alloc + end interface + + interface + module subroutine d_wrk_free(wk,info) + Implicit None + ! Arguments + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + end subroutine d_wrk_free + end interface + + interface + module subroutine d_wrk_clone(wk,wkout,info) + Implicit None + ! Arguments + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + end subroutine d_wrk_clone + end interface + + interface + module subroutine d_wrk_move_alloc(wk, b,info) + implicit none + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + end subroutine d_wrk_move_alloc + end interface + + interface + module subroutine d_wrk_cnv(wk,info,vmold) + Implicit None + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + end subroutine d_wrk_cnv + end interface + + interface + module function d_wrk_sizeof(wk) result(val) + implicit none + class(amg_dmlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + end function d_wrk_sizeof + end interface + + interface + module subroutine d_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_d_remap_data_type), target, intent(inout) :: rmp + class(amg_d_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine d_remap_data_clone + end interface + + interface + module subroutine d_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_d_remap_data_type), target, intent(inout) :: rmp + class(amg_d_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine d_remap_move_alloc + end interface + + contains ! ! Function returning the size of the amg_prec_type data structure @@ -683,37 +740,6 @@ contains end subroutine d_base_onelev_clone - subroutine d_base_onelev_move_alloc(lv, b,info) - use psb_base_mod - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - b%parms = lv%parms - b%szratio = lv%szratio - if (associated(lv%sm2,lv%sm2a)) then - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm2a - else - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm - end if - - call move_alloc(lv%aggr,b%aggr) - if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) - if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) - if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) - b%base_a => lv%base_a - b%base_desc => lv%base_desc - - end subroutine d_base_onelev_move_alloc - - function d_base_onelev_get_wrksize(lv) result(val) implicit none class(amg_d_onelev_type), intent(inout) :: lv @@ -751,275 +777,5 @@ contains end function d_base_onelev_get_wrksize - subroutine d_base_onelev_allocate_wrk(lv,info,vmold) - use psb_base_mod - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: nwv, i - info = psb_success_ - nwv = lv%get_wrksz() - if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) -!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() - if (info == 0) then - if (lv%remap_data%desc_ac_pre_remap%is_asb()) then - ! - ! Need to fix this, we need two different allocations - ! - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& - & desc2=lv%remap_data%desc_ac_pre_remap) - else - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) - end if - end if - - end subroutine d_base_onelev_allocate_wrk - - - subroutine d_base_onelev_free_wrk(lv,info) - use psb_base_mod - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: nwv,i - info = psb_success_ - - if (allocated(lv%wrk)) then - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) - end if - end subroutine d_base_onelev_free_wrk - - subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_dmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type), intent(in), optional :: vmold - type(psb_desc_type), intent(in), optional :: desc2 - ! - integer(psb_ipk_) :: i - - info = psb_success_ - call wk%free(info) -!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& -!!$ & present(desc2),desc%is_valid() - - allocate(wk%wv(nwv),stat=info) - if (present(desc2).and.(desc%is_valid())) then -!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() - if (desc2%get_local_cols()>desc%get_local_cols()) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - else if (present(desc2)) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else if (desc%is_valid()) then - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - - contains - subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold) - class(amg_dmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - class(psb_d_base_vect_type), intent(in), optional :: vmold - - integer(psb_ipk_) :: i - - call psb_geasb(wk%vx2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vy2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vtx,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vty,desc,info,& - & scratch=.true.,mold=vmold) - do i=1,nwv - call psb_geasb(wk%wv(i),desc,info,& - & scratch=.true.,mold=vmold) - end do - end subroutine inner_do_wrk_alloc - end subroutine d_wrk_alloc - - subroutine d_wrk_free(wk,info) - - Implicit None - - ! Arguments - class(amg_dmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - if (allocated(wk%tx)) deallocate(wk%tx, stat=info) - if (allocated(wk%ty)) deallocate(wk%ty, stat=info) - if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) - if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) - call wk%vtx%free(info) - call wk%vty%free(info) - call wk%vx2l%free(info) - call wk%vy2l%free(info) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%free(info) - end do - deallocate(wk%wv, stat=info) - end if - - end subroutine d_wrk_free - - subroutine d_wrk_clone(wk,wkout,info) - use psb_base_mod - Implicit None - - ! Arguments - class(amg_dmlprec_wrk_type), target, intent(inout) :: wk - class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - call psb_safe_ab_cpy(wk%tx,wkout%tx,info) - call psb_safe_ab_cpy(wk%ty,wkout%ty,info) - call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) - call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) - call wk%vtx%clone(wkout%vtx,info) - call wk%vty%clone(wkout%vty,info) - call wk%vx2l%clone(wkout%vx2l,info) - call wk%vy2l%clone(wkout%vy2l,info) - if (allocated(wkout%wv)) then - do i=1,size(wkout%wv) - call wkout%wv(i)%free(info) - end do - deallocate( wkout%wv) - end if - allocate(wkout%wv(size(wk%wv)),stat=info) - do i=1,size(wk%wv) - call wk%wv(i)%clone(wkout%wv(i),info) - end do - return - - end subroutine d_wrk_clone - - subroutine d_wrk_move_alloc(wk, b,info) - implicit none - class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - call move_alloc(wk%tx,b%tx) - call move_alloc(wk%ty,b%ty) - call move_alloc(wk%x2l,b%x2l) - call move_alloc(wk%y2l,b%y2l) - ! - ! Should define V%move_alloc.... - call move_alloc(wk%vtx%v,b%vtx%v) - call move_alloc(wk%vty%v,b%vty%v) - call move_alloc(wk%vx2l%v,b%vx2l%v) - call move_alloc(wk%vy2l%v,b%vy2l%v) - call move_alloc(wk%wv,b%wv) - - end subroutine d_wrk_move_alloc - - subroutine d_wrk_cnv(wk,info,vmold) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_dmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: i - - info = psb_success_ - if (present(vmold)) then - call wk%vtx%cnv(vmold) - call wk%vty%cnv(vmold) - call wk%vx2l%cnv(vmold) - call wk%vy2l%cnv(vmold) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%cnv(vmold) - end do - end if - end if - end subroutine d_wrk_cnv - - function d_wrk_sizeof(wk) result(val) - use psb_realloc_mod - implicit none - class(amg_dmlprec_wrk_type), intent(in) :: wk - integer(psb_epk_) :: val - integer :: i - val = 0 - val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%tx) - val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%ty) - val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%x2l) - val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%y2l) - val = val + wk%vtx%sizeof() - val = val + wk%vty%sizeof() - val = val + wk%vx2l%sizeof() - val = val + wk%vy2l%sizeof() - if (allocated(wk%wv)) then - do i=1, size(wk%wv) - val = val + wk%wv(i)%sizeof() - end do - end if - end function d_wrk_sizeof - - subroutine d_remap_data_clone(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_d_remap_data_type), target, intent(inout) :: rmp - class(amg_d_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) - call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) - end subroutine d_remap_data_clone - - subroutine d_remap_move_alloc(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_d_remap_data_type), target, intent(inout) :: rmp - class(amg_d_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call move_alloc(rmp%isrc,remap_out%isrc) - call move_alloc(rmp%nrsrc,remap_out%nrsrc) - call move_alloc(rmp%naggr,remap_out%naggr) - end subroutine d_remap_move_alloc end module amg_d_onelev_mod diff --git a/amgprec/amg_s_onelev_mod.f90 b/amgprec/amg_s_onelev_mod.f90 index 8f8b12b7..9b9d85e6 100644 --- a/amgprec/amg_s_onelev_mod.f90 +++ b/amgprec/amg_s_onelev_mod.f90 @@ -253,9 +253,7 @@ module amg_s_onelev_mod & s_base_onelev_free_wrk interface - subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - import :: psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lsspmat_type, psb_lpk_ - import :: amg_s_onelev_type + module subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) implicit none class(amg_s_onelev_type), intent(inout), target :: lv type(psb_sspmat_type), intent(in) :: a @@ -267,10 +265,7 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv) - import :: psb_s_base_sparse_mat, psb_s_base_vect_type, & - & psb_i_base_vect_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv) implicit none class(amg_s_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info @@ -282,10 +277,7 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) Implicit None ! Arguments class(amg_s_onelev_type), intent(in) :: lv @@ -298,10 +290,8 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity, prefix,global) Implicit None ! Arguments class(amg_s_onelev_type), intent(in) :: lv @@ -315,10 +305,7 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold) - import :: amg_s_onelev_type, psb_s_base_vect_type, psb_spk_, & - & psb_s_base_sparse_mat, psb_ipk_, psb_i_base_vect_type - ! Arguments + module subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold) class(amg_s_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold @@ -328,48 +315,32 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_free(lv,info) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_free(lv,info) implicit none - class(amg_s_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_s_base_onelev_free end interface interface - subroutine amg_s_base_onelev_free_smoothers(lv,info) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_free_smoothers(lv,info) implicit none - class(amg_s_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_s_base_onelev_free_smoothers end interface interface - subroutine amg_s_base_onelev_check(lv,info) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_check(lv,info) Implicit None - ! Arguments class(amg_s_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_s_base_onelev_check end interface interface - subroutine amg_s_base_onelev_setsm(lv,val,info,pos) - import :: psb_spk_, amg_s_onelev_type, amg_s_base_smoother_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_setsm(lv,val,info,pos) Implicit None - - ! Arguments class(amg_s_onelev_type), target, intent(inout) :: lv class(amg_s_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -378,12 +349,8 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_setsv(lv,val,info,pos) - import :: psb_spk_, amg_s_onelev_type, amg_s_base_solver_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_setsv(lv,val,info,pos) Implicit None - - ! Arguments class(amg_s_onelev_type), target, intent(inout) :: lv class(amg_s_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -392,12 +359,8 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_setag(lv,val,info,pos) - import :: psb_spk_, amg_s_onelev_type, amg_s_base_aggregator_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_setag(lv,val,info,pos) Implicit None - - ! Arguments class(amg_s_onelev_type), target, intent(inout) :: lv class(amg_s_base_aggregator_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -406,13 +369,8 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx) Implicit None - - ! Arguments class(amg_s_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -423,12 +381,8 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) Implicit None - ! Arguments class(amg_s_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what character(len=*), intent(in) :: val @@ -439,12 +393,8 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx) Implicit None - class(amg_s_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val @@ -455,11 +405,8 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& + module subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& & solver,tprol,global_num) - import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, amg_s_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type implicit none class(amg_s_onelev_type), intent(in) :: lv integer(psb_ipk_), intent(in) :: level @@ -470,8 +417,7 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - import + module subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) implicit none class(amg_s_onelev_type), target, intent(inout) :: lv real(psb_spk_), intent(in) :: alpha, beta @@ -480,8 +426,8 @@ module amg_s_onelev_mod integer(psb_ipk_), intent(out) :: info real(psb_spk_), optional :: work(:) end subroutine amg_s_base_onelev_map_rstr_a - subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty) - import + module subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) implicit none class(amg_s_onelev_type), target, intent(inout) :: lv real(psb_spk_), intent(in) :: alpha, beta @@ -493,8 +439,7 @@ module amg_s_onelev_mod end interface interface - subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - import + module subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) implicit none class(amg_s_onelev_type), target, intent(inout) :: lv real(psb_spk_), intent(in) :: alpha, beta @@ -504,8 +449,8 @@ module amg_s_onelev_mod real(psb_spk_), optional :: work(:) end subroutine amg_s_base_onelev_map_prol_a - subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - import + module subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,& + & work,vtx,vty) implicit none class(amg_s_onelev_type), target, intent(inout) :: lv real(psb_spk_), intent(in) :: alpha, beta @@ -516,6 +461,118 @@ module amg_s_onelev_mod end subroutine amg_s_base_onelev_map_prol_v end interface + interface + module subroutine s_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_onelev_move_alloc + end interface + + interface + module subroutine s_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + end subroutine s_base_onelev_allocate_wrk + end interface + + interface + module subroutine s_base_onelev_free_wrk(lv,info) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + end subroutine s_base_onelev_free_wrk + end interface + + interface + module subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + end subroutine s_wrk_alloc + end interface + + interface + module subroutine s_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_s_base_vect_type), intent(in), optional :: vmold + end subroutine s_inner_do_wrk_alloc + end interface + + interface + module subroutine s_wrk_free(wk,info) + Implicit None + ! Arguments + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + end subroutine s_wrk_free + end interface + + interface + module subroutine s_wrk_clone(wk,wkout,info) + Implicit None + ! Arguments + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + class(amg_smlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + end subroutine s_wrk_clone + end interface + + interface + module subroutine s_wrk_move_alloc(wk, b,info) + implicit none + class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + end subroutine s_wrk_move_alloc + end interface + + interface + module subroutine s_wrk_cnv(wk,info,vmold) + Implicit None + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + end subroutine s_wrk_cnv + end interface + + interface + module function s_wrk_sizeof(wk) result(val) + implicit none + class(amg_smlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + end function s_wrk_sizeof + end interface + + interface + module subroutine s_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_s_remap_data_type), target, intent(inout) :: rmp + class(amg_s_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine s_remap_data_clone + end interface + + interface + module subroutine s_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_s_remap_data_type), target, intent(inout) :: rmp + class(amg_s_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine s_remap_move_alloc + end interface + + contains ! ! Function returning the size of the amg_prec_type data structure @@ -683,37 +740,6 @@ contains end subroutine s_base_onelev_clone - subroutine s_base_onelev_move_alloc(lv, b,info) - use psb_base_mod - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - b%parms = lv%parms - b%szratio = lv%szratio - if (associated(lv%sm2,lv%sm2a)) then - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm2a - else - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm - end if - - call move_alloc(lv%aggr,b%aggr) - if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) - if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) - if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) - b%base_a => lv%base_a - b%base_desc => lv%base_desc - - end subroutine s_base_onelev_move_alloc - - function s_base_onelev_get_wrksize(lv) result(val) implicit none class(amg_s_onelev_type), intent(inout) :: lv @@ -751,275 +777,5 @@ contains end function s_base_onelev_get_wrksize - subroutine s_base_onelev_allocate_wrk(lv,info,vmold) - use psb_base_mod - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: nwv, i - info = psb_success_ - nwv = lv%get_wrksz() - if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) -!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() - if (info == 0) then - if (lv%remap_data%desc_ac_pre_remap%is_asb()) then - ! - ! Need to fix this, we need two different allocations - ! - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& - & desc2=lv%remap_data%desc_ac_pre_remap) - else - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) - end if - end if - - end subroutine s_base_onelev_allocate_wrk - - - subroutine s_base_onelev_free_wrk(lv,info) - use psb_base_mod - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: nwv,i - info = psb_success_ - - if (allocated(lv%wrk)) then - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) - end if - end subroutine s_base_onelev_free_wrk - - subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_smlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type), intent(in), optional :: vmold - type(psb_desc_type), intent(in), optional :: desc2 - ! - integer(psb_ipk_) :: i - - info = psb_success_ - call wk%free(info) -!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& -!!$ & present(desc2),desc%is_valid() - - allocate(wk%wv(nwv),stat=info) - if (present(desc2).and.(desc%is_valid())) then -!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() - if (desc2%get_local_cols()>desc%get_local_cols()) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - else if (present(desc2)) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else if (desc%is_valid()) then - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - - contains - subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold) - class(amg_smlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - class(psb_s_base_vect_type), intent(in), optional :: vmold - - integer(psb_ipk_) :: i - - call psb_geasb(wk%vx2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vy2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vtx,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vty,desc,info,& - & scratch=.true.,mold=vmold) - do i=1,nwv - call psb_geasb(wk%wv(i),desc,info,& - & scratch=.true.,mold=vmold) - end do - end subroutine inner_do_wrk_alloc - end subroutine s_wrk_alloc - - subroutine s_wrk_free(wk,info) - - Implicit None - - ! Arguments - class(amg_smlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - if (allocated(wk%tx)) deallocate(wk%tx, stat=info) - if (allocated(wk%ty)) deallocate(wk%ty, stat=info) - if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) - if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) - call wk%vtx%free(info) - call wk%vty%free(info) - call wk%vx2l%free(info) - call wk%vy2l%free(info) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%free(info) - end do - deallocate(wk%wv, stat=info) - end if - - end subroutine s_wrk_free - - subroutine s_wrk_clone(wk,wkout,info) - use psb_base_mod - Implicit None - - ! Arguments - class(amg_smlprec_wrk_type), target, intent(inout) :: wk - class(amg_smlprec_wrk_type), target, intent(inout) :: wkout - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - call psb_safe_ab_cpy(wk%tx,wkout%tx,info) - call psb_safe_ab_cpy(wk%ty,wkout%ty,info) - call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) - call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) - call wk%vtx%clone(wkout%vtx,info) - call wk%vty%clone(wkout%vty,info) - call wk%vx2l%clone(wkout%vx2l,info) - call wk%vy2l%clone(wkout%vy2l,info) - if (allocated(wkout%wv)) then - do i=1,size(wkout%wv) - call wkout%wv(i)%free(info) - end do - deallocate( wkout%wv) - end if - allocate(wkout%wv(size(wk%wv)),stat=info) - do i=1,size(wk%wv) - call wk%wv(i)%clone(wkout%wv(i),info) - end do - return - - end subroutine s_wrk_clone - - subroutine s_wrk_move_alloc(wk, b,info) - implicit none - class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - call move_alloc(wk%tx,b%tx) - call move_alloc(wk%ty,b%ty) - call move_alloc(wk%x2l,b%x2l) - call move_alloc(wk%y2l,b%y2l) - ! - ! Should define V%move_alloc.... - call move_alloc(wk%vtx%v,b%vtx%v) - call move_alloc(wk%vty%v,b%vty%v) - call move_alloc(wk%vx2l%v,b%vx2l%v) - call move_alloc(wk%vy2l%v,b%vy2l%v) - call move_alloc(wk%wv,b%wv) - - end subroutine s_wrk_move_alloc - - subroutine s_wrk_cnv(wk,info,vmold) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_smlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: i - - info = psb_success_ - if (present(vmold)) then - call wk%vtx%cnv(vmold) - call wk%vty%cnv(vmold) - call wk%vx2l%cnv(vmold) - call wk%vy2l%cnv(vmold) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%cnv(vmold) - end do - end if - end if - end subroutine s_wrk_cnv - - function s_wrk_sizeof(wk) result(val) - use psb_realloc_mod - implicit none - class(amg_smlprec_wrk_type), intent(in) :: wk - integer(psb_epk_) :: val - integer :: i - val = 0 - val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%tx) - val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%ty) - val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%x2l) - val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%y2l) - val = val + wk%vtx%sizeof() - val = val + wk%vty%sizeof() - val = val + wk%vx2l%sizeof() - val = val + wk%vy2l%sizeof() - if (allocated(wk%wv)) then - do i=1, size(wk%wv) - val = val + wk%wv(i)%sizeof() - end do - end if - end function s_wrk_sizeof - - subroutine s_remap_data_clone(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_s_remap_data_type), target, intent(inout) :: rmp - class(amg_s_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) - call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) - end subroutine s_remap_data_clone - - subroutine s_remap_move_alloc(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_s_remap_data_type), target, intent(inout) :: rmp - class(amg_s_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call move_alloc(rmp%isrc,remap_out%isrc) - call move_alloc(rmp%nrsrc,remap_out%nrsrc) - call move_alloc(rmp%naggr,remap_out%naggr) - end subroutine s_remap_move_alloc end module amg_s_onelev_mod diff --git a/amgprec/amg_z_onelev_mod.f90 b/amgprec/amg_z_onelev_mod.f90 index 309bb6a4..c4f70267 100644 --- a/amgprec/amg_z_onelev_mod.f90 +++ b/amgprec/amg_z_onelev_mod.f90 @@ -252,9 +252,7 @@ module amg_z_onelev_mod & z_base_onelev_free_wrk interface - subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - import :: psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_lzspmat_type, psb_lpk_ - import :: amg_z_onelev_type + module subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) implicit none class(amg_z_onelev_type), intent(inout), target :: lv type(psb_zspmat_type), intent(in) :: a @@ -266,10 +264,7 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv) - import :: psb_z_base_sparse_mat, psb_z_base_vect_type, & - & psb_i_base_vect_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv) implicit none class(amg_z_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info @@ -281,10 +276,7 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout, verbosity,prefix) Implicit None ! Arguments class(amg_z_onelev_type), intent(in) :: lv @@ -297,10 +289,8 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity, prefix,global) Implicit None ! Arguments class(amg_z_onelev_type), intent(in) :: lv @@ -314,10 +304,7 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold) - import :: amg_z_onelev_type, psb_z_base_vect_type, psb_dpk_, & - & psb_z_base_sparse_mat, psb_ipk_, psb_i_base_vect_type - ! Arguments + module subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold) class(amg_z_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold @@ -327,48 +314,32 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_free(lv,info) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_free(lv,info) implicit none - class(amg_z_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_z_base_onelev_free end interface interface - subroutine amg_z_base_onelev_free_smoothers(lv,info) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_free_smoothers(lv,info) implicit none - class(amg_z_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_z_base_onelev_free_smoothers end interface interface - subroutine amg_z_base_onelev_check(lv,info) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_check(lv,info) Implicit None - ! Arguments class(amg_z_onelev_type), intent(inout) :: lv integer(psb_ipk_), intent(out) :: info end subroutine amg_z_base_onelev_check end interface interface - subroutine amg_z_base_onelev_setsm(lv,val,info,pos) - import :: psb_dpk_, amg_z_onelev_type, amg_z_base_smoother_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_setsm(lv,val,info,pos) Implicit None - - ! Arguments class(amg_z_onelev_type), target, intent(inout) :: lv class(amg_z_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -377,12 +348,8 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_setsv(lv,val,info,pos) - import :: psb_dpk_, amg_z_onelev_type, amg_z_base_solver_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_setsv(lv,val,info,pos) Implicit None - - ! Arguments class(amg_z_onelev_type), target, intent(inout) :: lv class(amg_z_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -391,12 +358,8 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_setag(lv,val,info,pos) - import :: psb_dpk_, amg_z_onelev_type, amg_z_base_aggregator_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_setag(lv,val,info,pos) Implicit None - - ! Arguments class(amg_z_onelev_type), target, intent(inout) :: lv class(amg_z_base_aggregator_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info @@ -405,13 +368,8 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx) Implicit None - - ! Arguments class(amg_z_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val @@ -422,12 +380,8 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx) Implicit None - ! Arguments class(amg_z_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what character(len=*), intent(in) :: val @@ -438,12 +392,8 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type + module subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx) Implicit None - class(amg_z_onelev_type), intent(inout) :: lv character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val @@ -454,11 +404,8 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& + module subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,& & solver,tprol,global_num) - import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, & - & psb_ipk_, psb_epk_, psb_desc_type implicit none class(amg_z_onelev_type), intent(in) :: lv integer(psb_ipk_), intent(in) :: level @@ -469,8 +416,7 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - import + module subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) implicit none class(amg_z_onelev_type), target, intent(inout) :: lv complex(psb_dpk_), intent(in) :: alpha, beta @@ -479,8 +425,8 @@ module amg_z_onelev_mod integer(psb_ipk_), intent(out) :: info complex(psb_dpk_), optional :: work(:) end subroutine amg_z_base_onelev_map_rstr_a - subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,work,vtx,vty) - import + module subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) implicit none class(amg_z_onelev_type), target, intent(inout) :: lv complex(psb_dpk_), intent(in) :: alpha, beta @@ -492,8 +438,7 @@ module amg_z_onelev_mod end interface interface - subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - import + module subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) implicit none class(amg_z_onelev_type), target, intent(inout) :: lv complex(psb_dpk_), intent(in) :: alpha, beta @@ -503,8 +448,8 @@ module amg_z_onelev_mod complex(psb_dpk_), optional :: work(:) end subroutine amg_z_base_onelev_map_prol_a - subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - import + module subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,& + & work,vtx,vty) implicit none class(amg_z_onelev_type), target, intent(inout) :: lv complex(psb_dpk_), intent(in) :: alpha, beta @@ -515,6 +460,118 @@ module amg_z_onelev_mod end subroutine amg_z_base_onelev_map_prol_v end interface + interface + module subroutine z_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_onelev_move_alloc + end interface + + interface + module subroutine z_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + end subroutine z_base_onelev_allocate_wrk + end interface + + interface + module subroutine z_base_onelev_free_wrk(lv,info) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + end subroutine z_base_onelev_free_wrk + end interface + + interface + module subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + end subroutine z_wrk_alloc + end interface + + interface + module subroutine z_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_z_base_vect_type), intent(in), optional :: vmold + end subroutine z_inner_do_wrk_alloc + end interface + + interface + module subroutine z_wrk_free(wk,info) + Implicit None + ! Arguments + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + end subroutine z_wrk_free + end interface + + interface + module subroutine z_wrk_clone(wk,wkout,info) + Implicit None + ! Arguments + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + end subroutine z_wrk_clone + end interface + + interface + module subroutine z_wrk_move_alloc(wk, b,info) + implicit none + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + end subroutine z_wrk_move_alloc + end interface + + interface + module subroutine z_wrk_cnv(wk,info,vmold) + Implicit None + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + end subroutine z_wrk_cnv + end interface + + interface + module function z_wrk_sizeof(wk) result(val) + implicit none + class(amg_zmlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + end function z_wrk_sizeof + end interface + + interface + module subroutine z_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_z_remap_data_type), target, intent(inout) :: rmp + class(amg_z_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine z_remap_data_clone + end interface + + interface + module subroutine z_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_z_remap_data_type), target, intent(inout) :: rmp + class(amg_z_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + end subroutine z_remap_move_alloc + end interface + + contains ! ! Function returning the size of the amg_prec_type data structure @@ -682,37 +739,6 @@ contains end subroutine z_base_onelev_clone - subroutine z_base_onelev_move_alloc(lv, b,info) - use psb_base_mod - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - b%parms = lv%parms - b%szratio = lv%szratio - if (associated(lv%sm2,lv%sm2a)) then - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm2a - else - call move_alloc(lv%sm,b%sm) - call move_alloc(lv%sm2a,b%sm2a) - b%sm2 =>b%sm - end if - - call move_alloc(lv%aggr,b%aggr) - if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) - if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) - if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) - b%base_a => lv%base_a - b%base_desc => lv%base_desc - - end subroutine z_base_onelev_move_alloc - - function z_base_onelev_get_wrksize(lv) result(val) implicit none class(amg_z_onelev_type), intent(inout) :: lv @@ -750,275 +776,5 @@ contains end function z_base_onelev_get_wrksize - subroutine z_base_onelev_allocate_wrk(lv,info,vmold) - use psb_base_mod - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: nwv, i - info = psb_success_ - nwv = lv%get_wrksz() - if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) -!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() - if (info == 0) then - if (lv%remap_data%desc_ac_pre_remap%is_asb()) then - ! - ! Need to fix this, we need two different allocations - ! - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& - & desc2=lv%remap_data%desc_ac_pre_remap) - else - call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) - end if - end if - - end subroutine z_base_onelev_allocate_wrk - - - subroutine z_base_onelev_free_wrk(lv,info) - use psb_base_mod - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: nwv,i - info = psb_success_ - - if (allocated(lv%wrk)) then - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) - end if - end subroutine z_base_onelev_free_wrk - - subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_zmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type), intent(in), optional :: vmold - type(psb_desc_type), intent(in), optional :: desc2 - ! - integer(psb_ipk_) :: i - - info = psb_success_ - call wk%free(info) -!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& -!!$ & present(desc2),desc%is_valid() - - allocate(wk%wv(nwv),stat=info) - if (present(desc2).and.(desc%is_valid())) then -!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() - if (desc2%get_local_cols()>desc%get_local_cols()) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - else if (present(desc2)) then - call inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) - else if (desc%is_valid()) then - call inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) - end if - - contains - subroutine inner_do_wrk_alloc(wk,nwv,desc,vmold) - class(amg_zmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(in) :: nwv - type(psb_desc_type), intent(in) :: desc - class(psb_z_base_vect_type), intent(in), optional :: vmold - - integer(psb_ipk_) :: i - - call psb_geasb(wk%vx2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vy2l,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vtx,desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(wk%vty,desc,info,& - & scratch=.true.,mold=vmold) - do i=1,nwv - call psb_geasb(wk%wv(i),desc,info,& - & scratch=.true.,mold=vmold) - end do - end subroutine inner_do_wrk_alloc - end subroutine z_wrk_alloc - - subroutine z_wrk_free(wk,info) - - Implicit None - - ! Arguments - class(amg_zmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - if (allocated(wk%tx)) deallocate(wk%tx, stat=info) - if (allocated(wk%ty)) deallocate(wk%ty, stat=info) - if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) - if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) - call wk%vtx%free(info) - call wk%vty%free(info) - call wk%vx2l%free(info) - call wk%vy2l%free(info) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%free(info) - end do - deallocate(wk%wv, stat=info) - end if - - end subroutine z_wrk_free - - subroutine z_wrk_clone(wk,wkout,info) - use psb_base_mod - Implicit None - - ! Arguments - class(amg_zmlprec_wrk_type), target, intent(inout) :: wk - class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - info = psb_success_ - - call psb_safe_ab_cpy(wk%tx,wkout%tx,info) - call psb_safe_ab_cpy(wk%ty,wkout%ty,info) - call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) - call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) - call wk%vtx%clone(wkout%vtx,info) - call wk%vty%clone(wkout%vty,info) - call wk%vx2l%clone(wkout%vx2l,info) - call wk%vy2l%clone(wkout%vy2l,info) - if (allocated(wkout%wv)) then - do i=1,size(wkout%wv) - call wkout%wv(i)%free(info) - end do - deallocate( wkout%wv) - end if - allocate(wkout%wv(size(wk%wv)),stat=info) - do i=1,size(wk%wv) - call wk%wv(i)%clone(wkout%wv(i),info) - end do - return - - end subroutine z_wrk_clone - - subroutine z_wrk_move_alloc(wk, b,info) - implicit none - class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b - integer(psb_ipk_), intent(out) :: info - - call b%free(info) - call move_alloc(wk%tx,b%tx) - call move_alloc(wk%ty,b%ty) - call move_alloc(wk%x2l,b%x2l) - call move_alloc(wk%y2l,b%y2l) - ! - ! Should define V%move_alloc.... - call move_alloc(wk%vtx%v,b%vtx%v) - call move_alloc(wk%vty%v,b%vty%v) - call move_alloc(wk%vx2l%v,b%vx2l%v) - call move_alloc(wk%vy2l%v,b%vy2l%v) - call move_alloc(wk%wv,b%wv) - - end subroutine z_wrk_move_alloc - - subroutine z_wrk_cnv(wk,info,vmold) - use psb_base_mod - - Implicit None - - ! Arguments - class(amg_zmlprec_wrk_type), target, intent(inout) :: wk - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type), intent(in), optional :: vmold - ! - integer(psb_ipk_) :: i - - info = psb_success_ - if (present(vmold)) then - call wk%vtx%cnv(vmold) - call wk%vty%cnv(vmold) - call wk%vx2l%cnv(vmold) - call wk%vy2l%cnv(vmold) - if (allocated(wk%wv)) then - do i=1,size(wk%wv) - call wk%wv(i)%cnv(vmold) - end do - end if - end if - end subroutine z_wrk_cnv - - function z_wrk_sizeof(wk) result(val) - use psb_realloc_mod - implicit none - class(amg_zmlprec_wrk_type), intent(in) :: wk - integer(psb_epk_) :: val - integer :: i - val = 0 - val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%tx) - val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%ty) - val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%x2l) - val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%y2l) - val = val + wk%vtx%sizeof() - val = val + wk%vty%sizeof() - val = val + wk%vx2l%sizeof() - val = val + wk%vy2l%sizeof() - if (allocated(wk%wv)) then - do i=1, size(wk%wv) - val = val + wk%wv(i)%sizeof() - end do - end if - end function z_wrk_sizeof - - subroutine z_remap_data_clone(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_z_remap_data_type), target, intent(inout) :: rmp - class(amg_z_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) - call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) - end subroutine z_remap_data_clone - - subroutine z_remap_move_alloc(rmp, remap_out, info) - use psb_base_mod - implicit none - ! Arguments - class(amg_z_remap_data_type), target, intent(inout) :: rmp - class(amg_z_remap_data_type), target, intent(inout) :: remap_out - integer(psb_ipk_), intent(out) :: info - ! - integer(psb_ipk_) :: i - - info = psb_success_ - - call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) - if (info == psb_success_) & - & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) - remap_out%idest = rmp%idest - call move_alloc(rmp%isrc,remap_out%isrc) - call move_alloc(rmp%nrsrc,remap_out%nrsrc) - call move_alloc(rmp%naggr,remap_out%naggr) - end subroutine z_remap_move_alloc end module amg_z_onelev_mod diff --git a/amgprec/impl/level/Makefile b/amgprec/impl/level/Makefile index e7542084..bef9e099 100644 --- a/amgprec/impl/level/Makefile +++ b/amgprec/impl/level/Makefile @@ -75,7 +75,12 @@ amg_z_base_onelev_setag.o \ amg_z_base_onelev_setsm.o \ amg_z_base_onelev_setsv.o \ amg_z_base_onelev_map_rstr.o \ -amg_z_base_onelev_map_prol.o +amg_z_base_onelev_map_prol.o \ +amg_s_base_onelev_wrk_handle.o \ +amg_d_base_onelev_wrk_handle.o \ +amg_c_base_onelev_wrk_handle.o \ +amg_z_base_onelev_wrk_handle.o + LIBNAME=libamg_prec.a @@ -89,4 +94,4 @@ veryclean: clean /bin/rm -f $(LIBNAME) clean: - /bin/rm -f $(OBJS) $(LOCAL_MODS) + /bin/rm -f $(OBJS) $(LOCAL_MODS) *.smod diff --git a/amgprec/impl/level/amg_c_base_onelev_build.f90 b/amgprec/impl/level/amg_c_base_onelev_build.f90 index 592d5e9e..44c44066 100644 --- a/amgprec/impl/level/amg_c_base_onelev_build.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_build.f90 @@ -35,129 +35,132 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv) +submodule (amg_c_onelev_mod) amg_c_base_onelev_build_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_build - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - integer(psb_ipk_), intent(in), optional :: ilv - ! Local - integer(psb_ipk_) :: err,i,k, err_act - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: me, np - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + +contains + module subroutine amg_c_base_onelev_build(lv,info,amold,vmold,imold,ilv) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + integer(psb_ipk_), intent(in), optional :: ilv + ! Local + integer(psb_ipk_) :: err,i,k, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name, ch_err - name = 'amg_onelev_build' - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - if (.not.associated(lv%base_desc)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Unassociated base DESC') - goto 9999 - end if - info = psb_success_ - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - - ! - ! At top level(s) I may be using - ! a context with less processes - ! - if (me < 0) then -!!$ write(0,*) 'onelevbld: I am excluded from this one ' - else -!!$ write(0,*) me,' Going to build smoothers at this level ' - if (.not.allocated(lv%sm)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 + name = 'amg_onelev_build' + info=psb_success_ + err=0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 end if - if (.not.allocated(lv%sm%sv)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - lv%ac_nz_loc = lv%ac%get_nzeros() - lv%ac_nz_tot = lv%ac_nz_loc - select case(lv%parms%coarse_mat) - case(amg_distr_mat_) - call psb_sum(ctxt,lv%ac_nz_tot) - case(amg_repl_mat_) - ! Do nothing - case default - ! Should never get here - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Wrong lv%parms') - goto 9999 - end select - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',izero,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',izero,is_int_non_negative) - - call lv%sm%build(lv%base_a,lv%base_desc,info) - if (info == 0) then - if (allocated(lv%sm2a)) then - call lv%sm2a%build(lv%base_a,lv%base_desc,info) - lv%sm2 => lv%sm2a - else - lv%sm2 => lv%sm - end if - end if - if (info /=0 ) then + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + if (.not.associated(lv%base_desc)) then info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Smoother bld error') + & a_err='Unassociated base DESC') goto 9999 end if - - if (lv%sm%sv%is_global()) then - if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then - lv%parms%sweeps_pre = 1 - lv%parms%sweeps_post = 1 - if (me == 0) then - write(debug_unit,*) - if (present(ilv)) then - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" at level ',ilv - write(debug_unit,*) ' is configured as a global solver ' - else - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" is configured as a global solver ' + info = psb_success_ + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + ! + ! At top level(s) I may be using + ! a context with less processes + ! + if (me < 0) then +!!$ write(0,*) 'onelevbld: I am excluded from this one ' + else +!!$ write(0,*) me,' Going to build smoothers at this level ' + if (.not.allocated(lv%sm)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(lv%sm%sv)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + lv%ac_nz_loc = lv%ac%get_nzeros() + lv%ac_nz_tot = lv%ac_nz_loc + select case(lv%parms%coarse_mat) + case(amg_distr_mat_) + call psb_sum(ctxt,lv%ac_nz_tot) + case(amg_repl_mat_) + ! Do nothing + case default + ! Should never get here + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Wrong lv%parms') + goto 9999 + end select + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',izero,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',izero,is_int_non_negative) + + call lv%sm%build(lv%base_a,lv%base_desc,info) + if (info == 0) then + if (allocated(lv%sm2a)) then + call lv%sm2a%build(lv%base_a,lv%base_desc,info) + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if + end if + if (info /=0 ) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Smoother bld error') + goto 9999 + end if + + if (lv%sm%sv%is_global()) then + if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then + lv%parms%sweeps_pre = 1 + lv%parms%sweeps_post = 1 + if (me == 0) then + write(debug_unit,*) + if (present(ilv)) then + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" at level ',ilv + write(debug_unit,*) ' is configured as a global solver ' + else + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" is configured as a global solver ' + end if + write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if - write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if end if end if - end if - - if (any((/present(amold),present(vmold),present(imold)/))) & - & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) - call psb_erractionrestore(err_act) - return + if (any((/present(amold),present(vmold),present(imold)/))) & + & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_c_base_onelev_build + end subroutine amg_c_base_onelev_build +end submodule amg_c_base_onelev_build_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_check.f90 b/amgprec/impl/level/amg_c_base_onelev_check.f90 index 47d3cc0b..40e10f3a 100644 --- a/amgprec/impl/level/amg_c_base_onelev_check.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_check.f90 @@ -35,59 +35,60 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_check(lv,info) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_check_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_check - - Implicit None - - ! Arguments - class(amg_c_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='c_base_onelev_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',ione,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',ione,is_int_non_negative) - - if (allocated(lv%sm)) then - call lv%sm%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (allocated(lv%sm2a)) then - call lv%sm2a%check(info) - else if (.not.inner_check(lv%sm2,lv%sm)) then - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return contains - function inner_check(smp,sm) result(res) - implicit none - logical :: res - class(amg_c_base_smoother_type), intent(in), pointer :: smp - class(amg_c_base_smoother_type), intent(in), target :: sm + module subroutine amg_c_base_onelev_check(lv,info) + Implicit None - res = associated(smp, sm) - end function inner_check - -end subroutine amg_c_base_onelev_check + ! Arguments + class(amg_c_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_base_onelev_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',ione,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',ione,is_int_non_negative) + + if (allocated(lv%sm)) then + call lv%sm%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (allocated(lv%sm2a)) then + call lv%sm2a%check(info) + else if (.not.inner_check(lv%sm2,lv%sm)) then + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + contains + function inner_check(smp,sm) result(res) + implicit none + logical :: res + class(amg_c_base_smoother_type), intent(in), pointer :: smp + class(amg_c_base_smoother_type), intent(in), target :: sm + + res = associated(smp, sm) + end function inner_check + + end subroutine amg_c_base_onelev_check +end submodule amg_c_base_onelev_check_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_cnv.f90 b/amgprec/impl/level/amg_c_base_onelev_cnv.f90 index 6b5b248c..6842a83e 100644 --- a/amgprec/impl/level/amg_c_base_onelev_cnv.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_cnv.f90 @@ -35,33 +35,36 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_cnv_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_cnv - implicit none - - class(amg_c_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - - integer(psb_ipk_) :: i - - info = psb_success_ - if (any((/present(amold),present(vmold),present(imold)/))) then - if (allocated(lv%sm)) & - & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%sm2a)) & - & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%wrk)) & - & call lv%wrk%cnv(info,vmold=vmold) - if (info == psb_success_.and. lv%ac%is_asb()) & - & call lv%ac%cscnv(info,mold=amold) - if (info == psb_success_ .and. lv%desc_ac%is_ok() & - & .and. present(imold)) call lv%desc_ac%cnv(imold) - if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) - end if -end subroutine amg_c_base_onelev_cnv +contains + module subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold) + + implicit none + + class(amg_c_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + + integer(psb_ipk_) :: i + + info = psb_success_ + + if (any((/present(amold),present(vmold),present(imold)/))) then + if (allocated(lv%sm)) & + & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%sm2a)) & + & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%wrk)) & + & call lv%wrk%cnv(info,vmold=vmold) + if (info == psb_success_.and. lv%ac%is_asb()) & + & call lv%ac%cscnv(info,mold=amold) + if (info == psb_success_ .and. lv%desc_ac%is_ok() & + & .and. present(imold)) call lv%desc_ac%cnv(imold) + if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) + end if + end subroutine amg_c_base_onelev_cnv +end submodule amg_c_base_onelev_cnv_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_csetc.F90 b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 index fe26e9e3..6aec0b31 100644 --- a/amgprec/impl/level/amg_c_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_csetc.F90 @@ -35,277 +35,281 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_csetc_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetc - use amg_c_base_aggregator_mod - use amg_c_dec_aggregator_mod - use amg_c_symdec_aggregator_mod - use amg_c_jac_smoother - use amg_c_as_smoother - use amg_c_diag_solver - use amg_c_l1_diag_solver - use amg_c_jac_solver - use amg_c_ilu_solver - use amg_c_id_solver - use amg_c_gs_solver - use amg_c_ainv_solver - use amg_c_invk_solver - use amg_c_invt_solver + +contains + module subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_c_base_aggregator_mod + use amg_c_dec_aggregator_mod + use amg_c_symdec_aggregator_mod + use amg_c_jac_smoother + use amg_c_as_smoother + use amg_c_diag_solver + use amg_c_l1_diag_solver + use amg_c_jac_solver + use amg_c_ilu_solver + use amg_c_id_solver + use amg_c_gs_solver + use amg_c_ainv_solver + use amg_c_invk_solver + use amg_c_invt_solver #if defined(AMG_HAVE_SLU) - use amg_c_slu_solver + use amg_c_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_c_mumps_solver + use amg_c_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_c_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='c_base_onelev_csetc' - integer(psb_ipk_) :: ival - type(amg_c_base_smoother_type) :: amg_c_base_smoother_mold - type(amg_c_jac_smoother_type) :: amg_c_jac_smoother_mold - type(amg_c_l1_jac_smoother_type) :: amg_c_l1_jac_smoother_mold - type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold - type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold - type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold - type(amg_c_jac_solver_type) :: amg_c_jac_solver_mold - type(amg_c_l1_jac_solver_type) :: amg_c_l1_jac_solver_mold - type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold - type(amg_c_id_solver_type) :: amg_c_id_solver_mold - type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold - type(amg_c_bwgs_solver_type) :: amg_c_bwgs_solver_mold - type(amg_c_ainv_solver_type) :: amg_c_ainv_solver_mold - type(amg_c_invk_solver_type) :: amg_c_invk_solver_mold - type(amg_c_invt_solver_type) :: amg_c_invt_solver_mold + ! Arguments + class(amg_c_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='c_base_onelev_csetc' + integer(psb_ipk_) :: ival + type(amg_c_base_smoother_type) :: amg_c_base_smoother_mold + type(amg_c_jac_smoother_type) :: amg_c_jac_smoother_mold + type(amg_c_l1_jac_smoother_type) :: amg_c_l1_jac_smoother_mold + type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold + type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold + type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold + type(amg_c_jac_solver_type) :: amg_c_jac_solver_mold + type(amg_c_l1_jac_solver_type) :: amg_c_l1_jac_solver_mold + type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold + type(amg_c_id_solver_type) :: amg_c_id_solver_mold + type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold + type(amg_c_bwgs_solver_type) :: amg_c_bwgs_solver_mold + type(amg_c_ainv_solver_type) :: amg_c_ainv_solver_mold + type(amg_c_invk_solver_type) :: amg_c_invk_solver_mold + type(amg_c_invt_solver_type) :: amg_c_invt_solver_mold #if defined(AMG_HAVE_SLU) - type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold + type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold + type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold #endif - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - ival = lv%stringval(val) + ival = lv%stringval(val) - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(trim(what))) - case ('SMOOTHER_TYPE') - select case (psb_toupper(trim(val))) - case ('NOPREC','NONE') - call lv%set(amg_c_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos) - - case ('JAC','JACOBI') - call lv%set(amg_c_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos) - - case ('L1-JACOBI') - call lv%set(amg_c_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) - - case ('BJAC') - call lv%set(amg_c_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - - case ('L1-BJAC') - call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - - case ('AS') - call lv%set(amg_c_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - - case ('GS','FWGS') - call lv%set(amg_c_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('BWGS') - call lv%set(amg_c_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('FBGS') - call lv%set(amg_c_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') - call lv%set(amg_c_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post') - case ('L1-GS','L1-FWGS') - call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-BWGS') - call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-FBGS') - call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') - call lv%set(amg_c_l1_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(trim(what))) + case ('SMOOTHER_TYPE') + select case (psb_toupper(trim(val))) + case ('NOPREC','NONE') + call lv%set(amg_c_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (psb_toupper(trim(val))) - case ('NONE','NOPREC','FACT_NONE') - call lv%set(amg_c_id_solver_mold,info,pos=pos) + case ('JAC','JACOBI') + call lv%set(amg_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') - call lv%set(amg_c_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') - call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) + case ('BJAC') + call lv%set(amg_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - case ('GS','FGS','FWGS') - call lv%set(amg_c_gs_solver_mold,info,pos=pos) + case ('L1-BJAC') + call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - case ('BGS','BWGS') - call lv%set(amg_c_bwgs_solver_mold,info,pos=pos) + case ('AS') + call lv%set(amg_c_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - case ('AINV') - call lv%set(amg_c_ainv_solver_mold,info,pos=pos) - case ('INVK') - call lv%set(amg_c_invk_solver_mold,info,pos=pos) - case ('INVT') - call lv%set(amg_c_invt_solver_mold,info,pos=pos) - case ('ILU','ILUT','MILU') - call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case ('GS','FWGS') + call lv%set(amg_c_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('BWGS') + call lv%set(amg_c_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('FBGS') + call lv%set(amg_c_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') + call lv%set(amg_c_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post') + case ('L1-GS','L1-FWGS') + call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-BWGS') + call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-FBGS') + call lv%set(amg_c_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') + call lv%set(amg_c_l1_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (psb_toupper(trim(val))) + case ('NONE','NOPREC','FACT_NONE') + call lv%set(amg_c_id_solver_mold,info,pos=pos) + + case ('DIAG','JACOBI') + call lv%set(amg_c_diag_solver_mold,info,pos=pos) + + case ('L1-DIAG','L1-JACOBI') + call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) + + case ('GS','FGS','FWGS') + call lv%set(amg_c_gs_solver_mold,info,pos=pos) + + case ('BGS','BWGS') + call lv%set(amg_c_bwgs_solver_mold,info,pos=pos) + + case ('AINV') + call lv%set(amg_c_ainv_solver_mold,info,pos=pos) + case ('INVK') + call lv%set(amg_c_invk_solver_mold,info,pos=pos) + case ('INVT') + call lv%set(amg_c_invt_solver_mold,info,pos=pos) + case ('ILU','ILUT','MILU') + call lv%set(amg_c_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case ('SLU') - call lv%set(amg_c_slu_solver_mold,info,pos=pos) + case ('SLU') + call lv%set(amg_c_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case ('MUMPS') - call lv%set(amg_c_mumps_solver_mold,info,pos=pos) + case ('MUMPS') + call lv%set(amg_c_mumps_solver_mold,info,pos=pos) #endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select + case default + ! + ! Do nothing and hope for the best :) + ! + end select - case ('ML_CYCLE') - lv%parms%ml_cycle = amg_stringval(val) + case ('ML_CYCLE') + lv%parms%ml_cycle = amg_stringval(val) - case ('PAR_AGGR_ALG') - ival = amg_stringval(val) - lv%parms%par_aggr_alg = ival - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='aggregator deallocation?') + case ('PAR_AGGR_ALG') + ival = amg_stringval(val) + lv%parms%par_aggr_alg = ival + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='aggregator deallocation?') + goto 9999 + return + end if + end if + + select case(val) + case('DEC','DECOUPLED') + allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info) + case('SYMDEC') + allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') goto 9999 - return - end if - end if + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = amg_stringval(val) + + case ('AGGR_TYPE') + lv%parms%aggr_type = amg_stringval(val) + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = amg_stringval(val) + + case ('COARSE_MAT') + lv%parms%coarse_mat = amg_stringval(val) + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= amg_stringval(val) + + case ('AGGR_EIG') + lv%parms%aggr_eig = amg_stringval(val) + + case ('AGGR_FILTER') + lv%parms%aggr_filter = amg_stringval(val) + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = amg_stringval(val) + + case default + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - select case(val) - case('DEC','DECOUPLED') - allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info) - case('SYMDEC') - allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') - goto 9999 end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = amg_stringval(val) - - case ('AGGR_TYPE') - lv%parms%aggr_type = amg_stringval(val) - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = amg_stringval(val) - - case ('COARSE_MAT') - lv%parms%coarse_mat = amg_stringval(val) - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= amg_stringval(val) - - case ('AGGR_EIG') - lv%parms%aggr_eig = amg_stringval(val) - - case ('AGGR_FILTER') - lv%parms%aggr_filter = amg_stringval(val) - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = amg_stringval(val) - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_c_base_onelev_csetc + end subroutine amg_c_base_onelev_csetc +end submodule amg_c_base_onelev_csetc_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_cseti.F90 b/amgprec/impl/level/amg_c_base_onelev_cseti.F90 index d528b22f..0e33fc76 100644 --- a/amgprec/impl/level/amg_c_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_cseti.F90 @@ -35,234 +35,238 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_cseti_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_cseti - use amg_c_base_aggregator_mod - use amg_c_dec_aggregator_mod - use amg_c_symdec_aggregator_mod - use amg_c_jac_smoother - use amg_c_as_smoother - use amg_c_diag_solver - use amg_c_l1_diag_solver - use amg_c_ilu_solver - use amg_c_id_solver - use amg_c_gs_solver + +contains + module subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_c_base_aggregator_mod + use amg_c_dec_aggregator_mod + use amg_c_symdec_aggregator_mod + use amg_c_jac_smoother + use amg_c_as_smoother + use amg_c_diag_solver + use amg_c_l1_diag_solver + use amg_c_ilu_solver + use amg_c_id_solver + use amg_c_gs_solver #if defined(AMG_HAVE_SLU) - use amg_c_slu_solver + use amg_c_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_c_mumps_solver + use amg_c_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_c_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='c_base_onelev_cseti' - type(amg_c_base_smoother_type) :: amg_c_base_smoother_mold - type(amg_c_jac_smoother_type) :: amg_c_jac_smoother_mold - type(amg_c_l1_jac_smoother_type) :: amg_c_l1_jac_smoother_mold - type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold - type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold - type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold - type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold - type(amg_c_id_solver_type) :: amg_c_id_solver_mold - type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold - type(amg_c_bwgs_solver_type) :: amg_c_bwgs_solver_mold + ! Arguments + class(amg_c_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='c_base_onelev_cseti' + type(amg_c_base_smoother_type) :: amg_c_base_smoother_mold + type(amg_c_jac_smoother_type) :: amg_c_jac_smoother_mold + type(amg_c_l1_jac_smoother_type) :: amg_c_l1_jac_smoother_mold + type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold + type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold + type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold + type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold + type(amg_c_id_solver_type) :: amg_c_id_solver_mold + type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold + type(amg_c_bwgs_solver_type) :: amg_c_bwgs_solver_mold #if defined(AMG_HAVE_SLU) - type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold + type(amg_c_slu_solver_type) :: amg_c_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold + type(amg_c_mumps_solver_type) :: amg_c_mumps_solver_mold #endif - call psb_erractionsave(err_act) - info = psb_success_ + call psb_erractionsave(err_act) + info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(what)) - case ('SMOOTHER_TYPE') - select case (val) - case (amg_noprec_) - call lv%set(amg_c_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos) - - case (amg_jac_) - call lv%set(amg_c_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos) - - case (amg_l1_jac_) - call lv%set(amg_c_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) - - case (amg_bjac_) - call lv%set(amg_c_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - - case (amg_l1_bjac_) - call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - - case (amg_as_) - call lv%set(amg_c_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - - case (amg_fbgs_) - call lv%set(amg_c_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') - call lv%set(amg_c_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (amg_noprec_) + call lv%set(amg_c_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (val) - case (amg_f_none_) - call lv%set(amg_c_id_solver_mold,info,pos=pos) + case (amg_jac_) + call lv%set(amg_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_diag_solver_mold,info,pos=pos) - case (amg_diag_scale_) - call lv%set(amg_c_diag_solver_mold,info,pos=pos) + case (amg_l1_jac_) + call lv%set(amg_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) - case (amg_l1_diag_scale_) - call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) + case (amg_bjac_) + call lv%set(amg_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - case (amg_gs_) - call lv%set(amg_c_gs_solver_mold,info,pos=pos) + case (amg_l1_bjac_) + call lv%set(amg_c_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - case (amg_bwgs_) - call lv%set(amg_c_bwgs_solver_mold,info,pos=pos) + case (amg_as_) + call lv%set(amg_c_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) - call lv%set(amg_c_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case (amg_fbgs_) + call lv%set(amg_c_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_c_gs_solver_mold,info,pos='pre') + call lv%set(amg_c_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_c_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (val) + case (amg_f_none_) + call lv%set(amg_c_id_solver_mold,info,pos=pos) + + case (amg_diag_scale_) + call lv%set(amg_c_diag_solver_mold,info,pos=pos) + + case (amg_l1_diag_scale_) + call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos) + + case (amg_gs_) + call lv%set(amg_c_gs_solver_mold,info,pos=pos) + + case (amg_bwgs_) + call lv%set(amg_c_bwgs_solver_mold,info,pos=pos) + + case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) + call lv%set(amg_c_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case (amg_slu_) - call lv%set(amg_c_slu_solver_mold,info,pos=pos) + case (amg_slu_) + call lv%set(amg_c_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case (amg_mumps_) - call lv%set(amg_c_mumps_solver_mold,info,pos=pos) + case (amg_mumps_) + call lv%set(amg_c_mumps_solver_mold,info,pos=pos) #endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_pre = val + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_post = val + + case ('ML_CYCLE') + lv%parms%ml_cycle = val + + case ('PAR_AGGR_ALG') + lv%parms%par_aggr_alg = val + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + return + end if + end if + + select case(val) + case(amg_dec_aggr_) + allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info) + case(amg_sym_dec_aggr_) + allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_TYPE') + lv%parms%aggr_type = val + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + case default - ! - ! Do nothing and hope for the best :) - ! + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + end select - - - case ('SMOOTHER_SWEEPS') - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_pre = val - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_post = val - - case ('ML_CYCLE') - lv%parms%ml_cycle = val - - case ('PAR_AGGR_ALG') - lv%parms%par_aggr_alg = val - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - return - end if - end if - - select case(val) - case(amg_dec_aggr_) - allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info) - case(amg_sym_dec_aggr_) - allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = val - - case ('AGGR_TYPE') - lv%parms%aggr_type = val - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = val - - case ('COARSE_MAT') - lv%parms%coarse_mat = val - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= val - - case ('AGGR_EIG') - lv%parms%aggr_eig = val - - case ('AGGR_FILTER') - lv%parms%aggr_filter = val - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = val - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_c_base_onelev_cseti + end subroutine amg_c_base_onelev_cseti +end submodule amg_c_base_onelev_cseti_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_csetr.f90 b/amgprec/impl/level/amg_c_base_onelev_csetr.f90 index 1128fc6c..b7ee5a76 100644 --- a/amgprec/impl/level/amg_c_base_onelev_csetr.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_csetr.f90 @@ -35,71 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_csetr_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_csetr + +contains + module subroutine amg_c_base_onelev_csetr(lv,what,val,info,pos,idx) - Implicit None + Implicit None - ! Arguments - class(amg_c_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='c_base_onelev_csetr' + ! Arguments + class(amg_c_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='c_base_onelev_csetr' - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - select case (psb_toupper(what)) + select case (psb_toupper(what)) - case ('AGGR_OMEGA_VAL') - lv%parms%aggr_omega_val= val + case ('AGGR_OMEGA_VAL') + lv%parms%aggr_omega_val= val - case ('AGGR_THRESH') - lv%parms%aggr_thresh = val + case ('AGGR_THRESH') + lv%parms%aggr_thresh = val - case default - - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + case default + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) + + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - end select + end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_c_base_onelev_csetr + end subroutine amg_c_base_onelev_csetr +end submodule amg_c_base_onelev_csetr_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_descr.f90 b/amgprec/impl/level/amg_c_base_onelev_descr.f90 index 957944b4..1b7d6e61 100644 --- a/amgprec/impl/level/amg_c_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_descr.f90 @@ -42,114 +42,116 @@ ! 0: normal ! >1: increased details ! -subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_descr_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_descr - Implicit None - ! Arguments - class(amg_c_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - integer(psb_ipk_), intent(in), optional :: verbosity - character(len=*), intent(in), optional :: prefix - - - ! Local variables - integer(psb_ipk_) :: err_act - character(len=20), parameter :: name='amg_c_base_onelev_descr' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse - character(1024) :: prefix_ - type(psb_ctxt_type) :: pctxt - integer(psb_ipk_) :: pme, pnp - - - call psb_erractionsave(err_act) - - - coarse = (il==nl) - - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - - pctxt = lv%desc_ac%get_ctxt() - call psb_info(pctxt,pme,pnp) - write(iout_,*) trim(prefix_) - write(iout_,*) 'At level :',il,' we have ',pnp,' processes' - write(iout_,*) trim(prefix_) - if (il == ilmin) then - call lv%parms%mlcycledsc(iout_,info) - end if - if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then - if (allocated(lv%aggr)) then - call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) - else - write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 +contains + module subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) + Implicit None + ! Arguments + class(amg_c_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_c_base_onelev_descr' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp + + + call psb_erractionsave(err_act) + + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 + end if + if (verbosity_ < 0) goto 9998 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) write(iout_,*) trim(prefix_) - end if - - if (il > 1) then - - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' + write(iout_,*) trim(prefix_) + if (il == ilmin) then + call lv%parms%mlcycledsc(iout_,info) end if - - call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) - - if (nl > 1) then - if (allocated(lv%linmap%naggr)) then - write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & - & lv%linmap%nagtot - write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot - if (verbosity_>0) then - write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & - & lv%linmap%naggr(:) - else - write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& - & ' Local matrix sizes: min:', & - & lv%linmap%nagmin,' max:', lv%linmap%nagmax - write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& - & ' avg:', & - & lv%linmap%nagavg - end if - write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& - & ' Aggregation ratio: ', & - & lv%szratio + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then + if (allocated(lv%aggr)) then + call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) + else + write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 end if + write(iout_,*) trim(prefix_) end if - if (coarse.and.allocated(lv%sm)) & - & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) - end if + if (il > 1) then + + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + + call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) + + if (nl > 1) then + if (allocated(lv%linmap%naggr)) then + write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & + & lv%linmap%nagtot + write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot + if (verbosity_>0) then + write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & + & lv%linmap%naggr(:) + else + write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& + & ' Local matrix sizes: min:', & + & lv%linmap%nagmin,' max:', lv%linmap%nagmax + write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& + & ' avg:', & + & lv%linmap%nagavg + end if + write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& + & ' Aggregation ratio: ', & + & lv%szratio + end if + end if + + if (coarse.and.allocated(lv%sm)) & + & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) + end if 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_c_base_onelev_descr + end subroutine amg_c_base_onelev_descr +end submodule amg_c_base_onelev_descr_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_dump.f90 b/amgprec/impl/level/amg_c_base_onelev_dump.f90 index d06bf775..889c45d1 100644 --- a/amgprec/impl/level/amg_c_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_dump.f90 @@ -35,135 +35,137 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& - & smoother,solver,tprol,global_num) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_dump_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_dump - implicit none - class(amg_c_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: level - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num - ! Local variables - integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np - character(len=80) :: prefix_, frmt - character(len=1024) :: fname - logical :: ac_, rp_, tprol_, global_num_ - integer(psb_lpk_), allocatable :: ivr(:), ivc(:) - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_lev_c" - end if - - if (associated(lv%base_desc)) then - ctxt = lv%base_desc%get_context() - call psb_info(ctxt,iam,np) - else - iam = -1 - np = -1 - end if - if (present(ac)) then - ac_ = ac - else - ac_ = .false. - end if - if (present(rp)) then - rp_ = rp - else - rp_ = .false. - end if - if (present(tprol)) then - tprol_ = tprol - else - tprol_ = .false. - end if - if (present(global_num)) then - global_num_ = global_num - else - global_num_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - - if (np > 0) then - ni = floor(log10(1.0*np)) + 1 - write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' - write(fname(lname+1:lname+ni+2),frmt) '_p',iam - lname = lname + ni + 2 - end if - - if (global_num_) then - if (level == 1) then - if (ac_) then - ivr = lv%base_desc%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head,iv=ivr) - end if - else if (level >= 2) then - if (ac_) then - ivr = lv%desc_ac%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head,iv=ivr) - end if - if (rp_) then - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) - end if - if (tprol_) then - ! Tentative prolongator is stored with column indices already - ! in global numbering, so only IVR is needed. - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head,ivr=ivr) - end if - end if - else - if (level == 1) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head) - end if - else if (level >= 2) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head) - end if - if (rp_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head) - end if - if (tprol_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head) - end if - end if - end if - if (level >= 1) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) +contains + module subroutine amg_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& + & smoother,solver,tprol,global_num) + implicit none + class(amg_c_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num + ! Local variables + integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_, frmt + character(len=1024) :: fname + logical :: ac_, rp_, tprol_, global_num_ + integer(psb_lpk_), allocatable :: ivr(:), ivc(:) + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_lev_c" end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + + if (associated(lv%base_desc)) then + ctxt = lv%base_desc%get_context() + call psb_info(ctxt,iam,np) + else + iam = -1 + np = -1 end if - end if - -end subroutine amg_c_base_onelev_dump + if (present(ac)) then + ac_ = ac + else + ac_ = .false. + end if + if (present(rp)) then + rp_ = rp + else + rp_ = .false. + end if + if (present(tprol)) then + tprol_ = tprol + else + tprol_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + + if (np > 0) then + ni = floor(log10(1.0*np)) + 1 + write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' + write(fname(lname+1:lname+ni+2),frmt) '_p',iam + lname = lname + ni + 2 + end if + + if (global_num_) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then + if (ac_) then + ivr = lv%desc_ac%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head,iv=ivr) + end if + if (rp_) then + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) + end if + if (tprol_) then + ! Tentative prolongator is stored with column indices already + ! in global numbering, so only IVR is needed. + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head,ivr=ivr) + end if + end if + else + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head) + end if + if (rp_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head) + end if + if (tprol_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head) + end if + end if + end if + + if (level >= 1) then + if (allocated(lv%sm)) then + call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) + end if + if (allocated(lv%sm2a)) then + call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + end if + end if + + end subroutine amg_c_base_onelev_dump +end submodule amg_c_base_onelev_dump_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_free.f90 b/amgprec/impl/level/amg_c_base_onelev_free.f90 index b59487ed..d39c1bfa 100644 --- a/amgprec/impl/level/amg_c_base_onelev_free.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_free.f90 @@ -35,41 +35,43 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_free(lv,info) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_free_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_free - implicit none + +contains + module subroutine amg_c_base_onelev_free(lv,info) + implicit none - class(amg_c_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_c_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) - if (allocated(lv%wrk)) & - & call lv%wrk%free(info) + if (allocated(lv%wrk)) & + & call lv%wrk%free(info) - call lv%ac%free() - if (lv%desc_ac%is_ok()) & - & call lv%desc_ac%free(info) - call lv%linmap%free(info) + call lv%ac%free() + if (lv%desc_ac%is_ok()) & + & call lv%desc_ac%free(info) + call lv%linmap%free(info) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_a) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_desc) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_a) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_desc) - call lv%nullify() + call lv%nullify() -end subroutine amg_c_base_onelev_free + end subroutine amg_c_base_onelev_free +end submodule amg_c_base_onelev_free_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_free_smoothers.f90 b/amgprec/impl/level/amg_c_base_onelev_free_smoothers.f90 index 6e0e9d7e..36ce73ba 100644 --- a/amgprec/impl/level/amg_c_base_onelev_free_smoothers.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_free_smoothers.f90 @@ -35,26 +35,28 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_free_smoothers(lv,info) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_dree_smoothers_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_free_smoothers - implicit none + +contains + module subroutine amg_c_base_onelev_free_smoothers(lv,info) + implicit none - class(amg_c_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_c_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) -end subroutine amg_c_base_onelev_free_smoothers + end subroutine amg_c_base_onelev_free_smoothers +end submodule amg_c_base_onelev_dree_smoothers_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_map_prol.F90 b/amgprec/impl/level/amg_c_base_onelev_map_prol.F90 index 05580489..2bff609f 100644 --- a/amgprec/impl/level/amg_c_base_onelev_map_prol.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_map_prol.F90 @@ -35,112 +35,113 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_prol_v - - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv - complex(psb_spk_), intent(in) :: alpha, beta - type(psb_c_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), optional :: work(:) - type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_c_vect_type), pointer :: vtx_ +submodule (amg_c_onelev_mod) amg_c_base_onelev_map_prol_impl + use psb_base_mod + +contains + module subroutine amg_c_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_c_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), optional :: work(:) + type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty + + type(psb_c_vect_type), pointer :: vtx_ !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vtx)) then - vtx_ => vtx - else - vtx_ => lv%wrk%wv(1) - end if - -!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! -!!$ write(0,*) 'Remap handling ' - block - type(psb_ctxt_type) :: ctxt, nctxt - integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp - integer(psb_mpk_) :: me, np, rme, rnp - complex(psb_spk_), allocatable :: rsnd(:), rrcv(:) - type(psb_c_vect_type) :: tv + if (present(vtx)) then + vtx_ => vtx + else + vtx_ => lv%wrk%wv(1) + end if - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) +!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! +!!$ write(0,*) 'Remap handling ' + block + type(psb_ctxt_type) :: ctxt, nctxt + integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp + integer(psb_mpk_) :: me, np, rme, rnp +complex(psb_spk_), allocatable :: rsnd(:), rrcv(:) + type(psb_c_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal() - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + nctxt = lv%desc_ac%get_ctxt() + call psb_info(nctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal() - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal() - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) - rrcv = vect_v%get_vect() + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) + rrcv = vect_v%get_vect() !!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl - call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - end if - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + end if + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) !!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal() - - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info !!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal() !!$ call psb_realloc(nrc,rsnd,info) !!$ call psb_rcv(ctxt,rsnd(1:nrl),idest) !!$ call tv%set_vect(rsnd) - call psb_rcv(ctxt,tv%v%v(1:nrl),idest) - call tv%set_host() - call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end associate + call psb_rcv(ctxt,tv%v%v(1:nrl),idest) + call tv%set_host() + call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end associate !!$ write(0,*) me, ' Prolongator with remap done ' !!$ flush(0) !!$ call psb_barrier(ctxt) - end block - else - ! Default transfer - call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end if - -end subroutine amg_c_base_onelev_map_prol_v + end block + else + ! Default transfer + call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end if -subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_prol_a - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv - complex(psb_spk_), intent(in) :: alpha, beta - complex(psb_spk_), intent(inout) :: u(:) - complex(psb_spk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), optional :: work(:) + end subroutine amg_c_base_onelev_map_prol_v - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap P handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_V2U(alpha,v,beta,u,info,& - & work=work) - end if - -end subroutine amg_c_base_onelev_map_prol_a + module subroutine amg_c_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(inout) :: u(:) + complex(psb_spk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), optional :: work(:) + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap P handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_V2U(alpha,v,beta,u,info,& + & work=work) + end if + + end subroutine amg_c_base_onelev_map_prol_a +end submodule amg_c_base_onelev_map_prol_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 index 6beb0e0b..d7a29bed 100644 --- a/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 @@ -36,114 +36,115 @@ ! ! -subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& - & work,vtx,vty) +submodule (amg_c_onelev_mod) amg_c_base_onelev_map_rstr_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_rstr_v - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv - complex(psb_spk_), intent(in) :: alpha, beta - type(psb_c_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), optional :: work(:) - type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_c_vect_type), pointer :: vty_ - integer(psb_mpk_) :: me, np + +contains + module subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_c_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), optional :: work(:) + type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty + type(psb_c_vect_type), pointer :: vty_ + integer(psb_mpk_) :: me, np !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vty)) then - vty_ => vty - else - vty_ => lv%wrk%wv(1) - end if - - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! + if (present(vty)) then + vty_ => vty + else + vty_ => lv%wrk%wv(1) + end if + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! !!$ write(0,*) 'Remap handling not implemented yet ' - block - type(psb_ctxt_type) :: ctxt, rctxt - integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp - integer(psb_mpk_) :: rme, rnp - complex(psb_spk_), allocatable :: rsnd(:), rrcv(:) - type(psb_c_vect_type) :: tv - - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) - rctxt = lv%desc_ac%get_ctxt() - call psb_info(rctxt,rme,rnp) + block + type(psb_ctxt_type) :: ctxt, rctxt + integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp + integer(psb_mpk_) :: rme, rnp +complex(psb_spk_), allocatable :: rsnd(:), rrcv(:) + type(psb_c_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context map rstr',rme,rnp,me,np - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest !!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:) - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),& !!$ & psb_errstatus_fatal() !!$ flush(0) - call psb_barrier(ctxt) - call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& - & work=work,vtx=vtx,vty=vty_) - call tv%sync() - !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + call psb_barrier(ctxt) + call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& + & work=work,vtx=vtx,vty=vty_) + call tv%sync() + !rsnd = tv%get_vect() + !call psb_snd(ctxt,rsnd(1:nrl),idest) !!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal() - call psb_snd(ctxt,tv%v%v(1:nrl),idest) - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) + call psb_snd(ctxt,tv%v%v(1:nrl),idest) + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) !!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal() - call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - call vect_v%set_vect(rrcv) - end if - end associate + call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + call vect_v%set_vect(rrcv) + end if + end associate !!$ write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal() - end block - - else - ! Default transfer - block - type(psb_ctxt_type) :: ctxt, rctxt - ctxt = lv%linmap%p_desc_U%get_ctxt() - call psb_info(ctxt,me,np) + end block + + else + ! Default transfer + block + type(psb_ctxt_type) :: ctxt, rctxt + ctxt = lv%linmap%p_desc_U%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) me,' map_rstr calling U2V: ',me,np - call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& - & work=work,vtx=vtx,vty=vty_) - end block - end if + call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& + & work=work,vtx=vtx,vty=vty_) + end block + end if !!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal() -end subroutine amg_c_base_onelev_map_rstr_v + end subroutine amg_c_base_onelev_map_rstr_v -subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_map_rstr_a - implicit none - class(amg_c_onelev_type), target, intent(inout) :: lv - complex(psb_spk_), intent(in) :: alpha, beta - complex(psb_spk_), intent(inout) :: u(:) - complex(psb_spk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), optional :: work(:) + module subroutine amg_c_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(inout) :: u(:) + complex(psb_spk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), optional :: work(:) - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap R handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_U2V(alpha,u,beta,v,info,& - & work=work) - end if - -end subroutine amg_c_base_onelev_map_rstr_a + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap R handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_U2V(alpha,u,beta,v,info,& + & work=work) + end if + + end subroutine amg_c_base_onelev_map_rstr_a +end submodule amg_c_base_onelev_map_rstr_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_mat_asb.f90 b/amgprec/impl/level/amg_c_base_onelev_mat_asb.f90 index 1a762987..992fe787 100644 --- a/amgprec/impl/level/amg_c_base_onelev_mat_asb.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_mat_asb.f90 @@ -83,109 +83,111 @@ ! info - integer, output. ! Error code. ! -subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_mat_asb_impl use psb_base_mod use amg_base_prec_type - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_mat_asb - - implicit none - - ! Arguments - class(amg_c_onelev_type), intent(inout), target :: lv - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(inout) :: desc_a - integer(psb_lpk_), intent(inout) :: nlaggr(:) - integer(psb_lpk_), intent(inout) :: ilaggr(:) - type(psb_lcspmat_type), intent(inout) :: t_prol - integer(psb_ipk_), intent(out) :: info +contains + module subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - ! Local variables - character(len=24) :: name - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - type(psb_cspmat_type) :: ac, op_restr, op_prol - integer(psb_ipk_) :: nzl, inl - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 - logical, parameter :: do_timings=.false. + implicit none - name='amg_c_onelev_mat_asb' - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - info = psb_success_ - ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) - if ((do_timings).and.(idx_matbld==-1)) & - & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") - if ((do_timings).and.(idx_matasb==-1)) & - & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") - if ((do_timings).and.(idx_mapbld==-1)) & - & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - - call amg_check_def(lv%parms%aggr_prol,'Smoother',& - & amg_smooth_prol_,is_legal_ml_aggr_prol) - call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& - & amg_distr_mat_,is_legal_ml_coarse_mat) - call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& - & amg_no_filter_mat_,is_legal_aggr_filter) - call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& - & amg_eig_est_,is_legal_ml_aggr_omega_alg) - call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& - & amg_max_norm_,is_legal_ml_aggr_eig) - call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega) + ! Arguments + class(amg_c_onelev_type), intent(inout), target :: lv + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(inout) :: nlaggr(:) + integer(psb_lpk_), intent(inout) :: ilaggr(:) + type(psb_lcspmat_type), intent(inout) :: t_prol + integer(psb_ipk_), intent(out) :: info - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by lv%iprcparm(amg_aggr_prol_) - ! - if (do_timings) call psb_tic(idx_matbld) - call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& - & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) - if (do_timings) call psb_toc(idx_matbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') - goto 9999 - end if + ! Local variables + character(len=24) :: name + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + type(psb_cspmat_type) :: ac, op_restr, op_prol + integer(psb_ipk_) :: nzl, inl + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 + logical, parameter :: do_timings=.false. - ! - ! Now build its descriptor and convert global indices for - ! ac, op_restr and op_prol - ! - if (do_timings) call psb_tic(idx_matasb) - if (info == psb_success_) & - & call lv%aggr%mat_asb(lv%parms,a,desc_a,& - & lv%ac,lv%desc_ac,op_prol,op_restr,info) - if (do_timings) call psb_toc(idx_matasb) - if (do_timings) call psb_tic(idx_mapbld) - if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - - if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& - & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) - if (do_timings) call psb_toc(idx_mapbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') - goto 9999 - end if - ! - ! Fix the base_a and base_desc pointers for handling of residuals. - ! This is correct because this routine is only called at levels >=2. - ! - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac + name='amg_c_onelev_mat_asb' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if ((do_timings).and.(idx_matbld==-1)) & + & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") + if ((do_timings).and.(idx_matasb==-1)) & + & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") + if ((do_timings).and.(idx_mapbld==-1)) & + & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - call psb_erractionrestore(err_act) - return + call amg_check_def(lv%parms%aggr_prol,'Smoother',& + & amg_smooth_prol_,is_legal_ml_aggr_prol) + call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& + & amg_distr_mat_,is_legal_ml_coarse_mat) + call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& + & amg_no_filter_mat_,is_legal_aggr_filter) + call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& + & amg_eig_est_,is_legal_ml_aggr_omega_alg) + call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& + & amg_max_norm_,is_legal_ml_aggr_eig) + call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by lv%iprcparm(amg_aggr_prol_) + ! + if (do_timings) call psb_tic(idx_matbld) + call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& + & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) + if (do_timings) call psb_toc(idx_matbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') + goto 9999 + end if + + ! + ! Now build its descriptor and convert global indices for + ! ac, op_restr and op_prol + ! + if (do_timings) call psb_tic(idx_matasb) + if (info == psb_success_) & + & call lv%aggr%mat_asb(lv%parms,a,desc_a,& + & lv%ac,lv%desc_ac,op_prol,op_restr,info) + if (do_timings) call psb_toc(idx_matasb) + if (do_timings) call psb_tic(idx_mapbld) + if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + + if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& + & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) + if (do_timings) call psb_toc(idx_mapbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') + goto 9999 + end if + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_c_base_onelev_mat_asb + end subroutine amg_c_base_onelev_mat_asb +end submodule amg_c_base_onelev_mat_asb_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 index fffb2bc7..535e828d 100644 --- a/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_memory_use.f90 @@ -42,109 +42,112 @@ ! 0: normal ! >1: increased details ! -subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_memory_use_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_memory_use - Implicit None - ! Arguments - class(amg_c_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - character(len=*), intent(in), optional :: prefix - integer(psb_ipk_), intent(in), optional :: verbosity - logical, intent(in), optional :: global - - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: err_act ,me, np - character(len=20), parameter :: name='amg_c_base_onelev_memory_use' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse, global_ - character(1024) :: prefix_ - integer(psb_epk_), allocatable :: sz(:) - - - call psb_erractionsave(err_act) - - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - coarse = (il==nl) +contains + module subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity,prefix,global) + Implicit None + ! Arguments + class(amg_c_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + character(len=*), intent(in), optional :: prefix + integer(psb_ipk_), intent(in), optional :: verbosity + logical, intent(in), optional :: global - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(global)) then - global_ = global - else - global_ = .true. - end if + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act ,me, np + character(len=20), parameter :: name='amg_c_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse, global_ + character(1024) :: prefix_ + integer(psb_epk_), allocatable :: sz(:) - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + call psb_erractionsave(err_act) - if (global_) then - allocate(sz(6)) - sz(:) = 0 - sz(1) = lv%base_a%sizeof() - sz(2) = lv%base_desc%sizeof() - if (il >1) sz(3) = lv%linmap%sizeof() - if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() - if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() - if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() - call psb_sum(ctxt,sz) - if (me == 0) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', sz(1) - write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if - - else - if ((me == 0).or.(verbosity_>0)) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() - write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 end if - endif + if (verbosity_ < 0) goto 9998 + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + + if (global_) then + allocate(sz(6)) + sz(:) = 0 + sz(1) = lv%base_a%sizeof() + sz(2) = lv%base_desc%sizeof() + if (il >1) sz(3) = lv%linmap%sizeof() + if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() + if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() + if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() + call psb_sum(ctxt,sz) + if (me == 0) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', sz(1) + write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + end if + + else + if ((me == 0).or.(verbosity_>0)) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() + write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + end if + endif 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_c_base_onelev_memory_use + end subroutine amg_c_base_onelev_memory_use +end submodule amg_c_base_onelev_memory_use_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_setag.f90 b/amgprec/impl/level/amg_c_base_onelev_setag.f90 index b33eb0a0..062cec69 100644 --- a/amgprec/impl/level/amg_c_base_onelev_setag.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_setag.f90 @@ -35,48 +35,50 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_setag(lv,val,info,pos) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_setag_impl use psb_base_mod - use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_setag - - implicit none - - ! Arguments - class(amg_c_onelev_type), target, intent(inout) :: lv - class(amg_c_base_aggregator_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setag' +contains + module subroutine amg_c_base_onelev_setag(lv,val,info,pos) - info = psb_success_ + implicit none - ! Ignore pos for aggregator - - if (allocated(lv%aggr)) then - if (.not.same_type_as(lv%aggr,val)) then - call lv%aggr%free(info) - deallocate(lv%aggr,stat=info) + ! Arguments + class(amg_c_onelev_type), target, intent(inout) :: lv + class(amg_c_base_aggregator_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setag' + + info = psb_success_ + + ! Ignore pos for aggregator + + if (allocated(lv%aggr)) then + if (.not.same_type_as(lv%aggr,val)) then + call lv%aggr%free(info) + deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%aggr)) then + allocate(lv%aggr,mold=val,stat=info) if (info /= 0) then info = 3111 return end if + lv%parms%par_aggr_alg = amg_ext_aggr_ + lv%parms%aggr_type = amg_noalg_ + call lv%aggr%default() end if - end if - - if (.not.allocated(lv%aggr)) then - allocate(lv%aggr,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - lv%parms%par_aggr_alg = amg_ext_aggr_ - lv%parms%aggr_type = amg_noalg_ - call lv%aggr%default() - end if - -end subroutine amg_c_base_onelev_setag + end subroutine amg_c_base_onelev_setag + +end submodule amg_c_base_onelev_setag_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_setsm.F90 b/amgprec/impl/level/amg_c_base_onelev_setsm.F90 index 5009651a..a2bcec50 100644 --- a/amgprec/impl/level/amg_c_base_onelev_setsm.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_setsm.F90 @@ -35,72 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_setsm(lev,val,info,pos) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_setsm_impl use psb_base_mod - use amg_c_prec_mod, amg_protect_name => amg_c_base_onelev_setsm - - implicit none - - ! Arguments - class(amg_c_onelev_type), target, intent(inout) :: lev - class(amg_c_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsm' - - info = psb_success_ +contains + module subroutine amg_c_base_onelev_setsm(lv,val,info,pos) + implicit none - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Arguments + class(amg_c_onelev_type), target, intent(inout) :: lv + class(amg_c_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if (ipos_ == amg_smooth_both_) then - if (allocated(lev%sm2a)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - lev%sm2 => null() end if - end if - - select case(ipos_) - case(amg_smooth_pre_, amg_smooth_both_) - if (allocated(lev%sm)) then - if (.not.same_type_as(lev%sm,val)) then - call lev%sm%free(info) - deallocate(lev%sm, stat=info) + + if (ipos_ == amg_smooth_both_) then + if (allocated(lv%sm2a)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + lv%sm2 => null() end if - endif - if (.not.allocated(lev%sm)) then - allocate(lev%sm,mold=val) end if - call lev%sm%default() - if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm - case(amg_smooth_post_) - if (allocated(lev%sm2a)) then - if (.not.same_type_as(lev%sm2a,val)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - endif - end if - if (.not.allocated(lev%sm2a)) then - allocate(lev%sm2a,mold=val) - end if - call lev%sm2a%default() - lev%sm2 => lev%sm2a - end select - -end subroutine amg_c_base_onelev_setsm + select case(ipos_) + case(amg_smooth_pre_, amg_smooth_both_) + if (allocated(lv%sm)) then + if (.not.same_type_as(lv%sm,val)) then + call lv%sm%free(info) + deallocate(lv%sm, stat=info) + end if + endif + if (.not.allocated(lv%sm)) then + allocate(lv%sm,mold=val) + end if + call lv%sm%default() + if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm + case(amg_smooth_post_) + if (allocated(lv%sm2a)) then + if (.not.same_type_as(lv%sm2a,val)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + endif + end if + if (.not.allocated(lv%sm2a)) then + allocate(lv%sm2a,mold=val) + end if + call lv%sm2a%default() + lv%sm2 => lv%sm2a + end select + + end subroutine amg_c_base_onelev_setsm + +end submodule amg_c_base_onelev_setsm_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_setsv.F90 b/amgprec/impl/level/amg_c_base_onelev_setsv.F90 index d0185318..79e62273 100644 --- a/amgprec/impl/level/amg_c_base_onelev_setsv.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_setsv.F90 @@ -35,110 +35,111 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_c_base_onelev_setsv(lev,val,info,pos) - +submodule (amg_c_onelev_mod) amg_c_base_onelev_setsv_impl use psb_base_mod - use amg_c_prec_mod, amg_protect_name => amg_c_base_onelev_setsv - - implicit none - - ! Arguments - class(amg_c_onelev_type), target, intent(inout) :: lev - class(amg_c_base_solver_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsv' +contains + module subroutine amg_c_base_onelev_setsv(lv,val,info,pos) + implicit none - info = psb_success_ + ! Arguments + class(amg_c_onelev_type), target, intent(inout) :: lv + class(amg_c_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then - if (allocated(lev%sm)) then - if (allocated(lev%sm%sv)) then - if (.not.same_type_as(lev%sm%sv,val)) then - call lev%sm%sv%free(info) - if (info == 0) deallocate(lev%sm%sv,stat=info) + end if + + if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then + if (allocated(lv%sm)) then + if (allocated(lv%sm%sv)) then + if (.not.same_type_as(lv%sm%sv,val)) then + call lv%sm%sv%free(info) + if (info == 0) deallocate(lv%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%sm%sv)) then + allocate(lv%sm%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if + call lv%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + end if - - if (.not.allocated(lev%sm%sv)) then - allocate(lev%sm%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - end if - end if - ! - ! If POS was not specified and therefore we have amg_smooth_both_ - ! we need to update sm2a *only* if it was already allocated, - ! otherwise it is not needed (since we have just fixed %sm in the - ! pre section). - ! + ! + ! If POS was not specified and therefore we have amg_smooth_both_ + ! we need to update sm2a *only* if it was already allocated, + ! otherwise it is not needed (since we have just fixed %sm in the + ! pre section). + ! - if ((ipos_ == amg_smooth_post_).or. & - ((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then + if ((ipos_ == amg_smooth_post_).or. & + ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then - if (allocated(lev%sm2a)) then - if (allocated(lev%sm2a%sv)) then - if (.not.same_type_as(lev%sm2a%sv,val)) then - call lev%sm2a%sv%free(info) - if (info == 0) deallocate(lev%sm2a%sv,stat=info) + if (allocated(lv%sm2a)) then + if (allocated(lv%sm2a%sv)) then + if (.not.same_type_as(lv%sm2a%sv,val)) then + call lv%sm2a%sv%free(info) + if (info == 0) deallocate(lv%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lv%sm2a%sv)) then + allocate(lv%sm2a%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if - end if - if (.not.allocated(lev%sm2a%sv)) then - allocate(lev%sm2a%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm2a%sv%default() - - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - - end if - - end if - -end subroutine amg_c_base_onelev_setsv + call lv%sm2a%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + + end if + + end if + + end subroutine amg_c_base_onelev_setsv + +end submodule amg_c_base_onelev_setsv_impl diff --git a/amgprec/impl/level/amg_c_base_onelev_wrk_handle.f90 b/amgprec/impl/level/amg_c_base_onelev_wrk_handle.f90 new file mode 100644 index 00000000..7013ec16 --- /dev/null +++ b/amgprec/impl/level/amg_c_base_onelev_wrk_handle.f90 @@ -0,0 +1,333 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +submodule (amg_c_onelev_mod) amg_c_base_onelev_wrk_handle_impl + use psb_base_mod + +contains + + module subroutine c_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + b%parms = lv%parms + b%szratio = lv%szratio + if (associated(lv%sm2,lv%sm2a)) then + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + + call move_alloc(lv%aggr,b%aggr) + if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) + if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) + if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) + b%base_a => lv%base_a + b%base_desc => lv%base_desc + + end subroutine c_base_onelev_move_alloc + + module subroutine c_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv, i + info = psb_success_ + nwv = lv%get_wrksz() + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) +!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() + if (info == 0) then + if (lv%remap_data%desc_ac_pre_remap%is_asb()) then + ! + ! Need to fix this, we need two different allocations + ! + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& + & desc2=lv%remap_data%desc_ac_pre_remap) + else + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end if + end if + + end subroutine c_base_onelev_allocate_wrk + + module subroutine c_base_onelev_free_wrk(lv,info) + implicit none + class(amg_c_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv,i + info = psb_success_ + + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if + end subroutine c_base_onelev_free_wrk + + module subroutine c_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) +!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& +!!$ & present(desc2),desc%is_valid() + + allocate(wk%wv(nwv),stat=info) + if (present(desc2).and.(desc%is_valid())) then +!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() + if (desc2%get_local_cols()>desc%get_local_cols()) then + call c_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else + call c_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + else if (present(desc2)) then + call c_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else if (desc%is_valid()) then + call c_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + + contains + end subroutine c_wrk_alloc + + module subroutine c_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_c_base_vect_type), intent(in), optional :: vmold + + integer(psb_ipk_) :: i + + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + do i=1,nwv + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + end subroutine c_inner_do_wrk_alloc + + + module subroutine c_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine c_wrk_free + + module subroutine c_wrk_clone(wk,wkout,info) + Implicit None + + ! Arguments + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + class(amg_cmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) + end do + return + + end subroutine c_wrk_clone + + module subroutine c_wrk_move_alloc(wk, b,info) + implicit none + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine c_wrk_move_alloc + + module subroutine c_wrk_cnv(wk,info,vmold) + Implicit None + + ! Arguments + class(amg_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + if (present(vmold)) then + call wk%vtx%cnv(vmold) + call wk%vty%cnv(vmold) + call wk%vx2l%cnv(vmold) + call wk%vy2l%cnv(vmold) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%cnv(vmold) + end do + end if + end if + end subroutine c_wrk_cnv + + module function c_wrk_sizeof(wk) result(val) + implicit none + class(amg_cmlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + integer :: i + val = 0 + val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%tx) + val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%ty) + val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%x2l) + val = val + (1_psb_epk_ * (2*psb_sizeof_sp)) * psb_size(wk%y2l) + val = val + wk%vtx%sizeof() + val = val + wk%vty%sizeof() + val = val + wk%vx2l%sizeof() + val = val + wk%vy2l%sizeof() + if (allocated(wk%wv)) then + do i=1, size(wk%wv) + val = val + wk%wv(i)%sizeof() + end do + end if + end function c_wrk_sizeof + + module subroutine c_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_c_remap_data_type), target, intent(inout) :: rmp + class(amg_c_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) + call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) + end subroutine c_remap_data_clone + + module subroutine c_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_c_remap_data_type), target, intent(inout) :: rmp + class(amg_c_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call move_alloc(rmp%isrc,remap_out%isrc) + call move_alloc(rmp%nrsrc,remap_out%nrsrc) + call move_alloc(rmp%naggr,remap_out%naggr) + end subroutine c_remap_move_alloc + +end submodule amg_c_base_onelev_wrk_handle_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_build.f90 b/amgprec/impl/level/amg_d_base_onelev_build.f90 index d92f1b78..f517a715 100644 --- a/amgprec/impl/level/amg_d_base_onelev_build.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_build.f90 @@ -35,129 +35,132 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv) +submodule (amg_d_onelev_mod) amg_d_base_onelev_build_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_build - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - integer(psb_ipk_), intent(in), optional :: ilv - ! Local - integer(psb_ipk_) :: err,i,k, err_act - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: me, np - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + +contains + module subroutine amg_d_base_onelev_build(lv,info,amold,vmold,imold,ilv) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + integer(psb_ipk_), intent(in), optional :: ilv + ! Local + integer(psb_ipk_) :: err,i,k, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name, ch_err - name = 'amg_onelev_build' - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - if (.not.associated(lv%base_desc)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Unassociated base DESC') - goto 9999 - end if - info = psb_success_ - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - - ! - ! At top level(s) I may be using - ! a context with less processes - ! - if (me < 0) then -!!$ write(0,*) 'onelevbld: I am excluded from this one ' - else -!!$ write(0,*) me,' Going to build smoothers at this level ' - if (.not.allocated(lv%sm)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 + name = 'amg_onelev_build' + info=psb_success_ + err=0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 end if - if (.not.allocated(lv%sm%sv)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - lv%ac_nz_loc = lv%ac%get_nzeros() - lv%ac_nz_tot = lv%ac_nz_loc - select case(lv%parms%coarse_mat) - case(amg_distr_mat_) - call psb_sum(ctxt,lv%ac_nz_tot) - case(amg_repl_mat_) - ! Do nothing - case default - ! Should never get here - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Wrong lv%parms') - goto 9999 - end select - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',izero,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',izero,is_int_non_negative) - - call lv%sm%build(lv%base_a,lv%base_desc,info) - if (info == 0) then - if (allocated(lv%sm2a)) then - call lv%sm2a%build(lv%base_a,lv%base_desc,info) - lv%sm2 => lv%sm2a - else - lv%sm2 => lv%sm - end if - end if - if (info /=0 ) then + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + if (.not.associated(lv%base_desc)) then info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Smoother bld error') + & a_err='Unassociated base DESC') goto 9999 end if - - if (lv%sm%sv%is_global()) then - if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then - lv%parms%sweeps_pre = 1 - lv%parms%sweeps_post = 1 - if (me == 0) then - write(debug_unit,*) - if (present(ilv)) then - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" at level ',ilv - write(debug_unit,*) ' is configured as a global solver ' - else - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" is configured as a global solver ' + info = psb_success_ + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + ! + ! At top level(s) I may be using + ! a context with less processes + ! + if (me < 0) then +!!$ write(0,*) 'onelevbld: I am excluded from this one ' + else +!!$ write(0,*) me,' Going to build smoothers at this level ' + if (.not.allocated(lv%sm)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(lv%sm%sv)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + lv%ac_nz_loc = lv%ac%get_nzeros() + lv%ac_nz_tot = lv%ac_nz_loc + select case(lv%parms%coarse_mat) + case(amg_distr_mat_) + call psb_sum(ctxt,lv%ac_nz_tot) + case(amg_repl_mat_) + ! Do nothing + case default + ! Should never get here + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Wrong lv%parms') + goto 9999 + end select + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',izero,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',izero,is_int_non_negative) + + call lv%sm%build(lv%base_a,lv%base_desc,info) + if (info == 0) then + if (allocated(lv%sm2a)) then + call lv%sm2a%build(lv%base_a,lv%base_desc,info) + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if + end if + if (info /=0 ) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Smoother bld error') + goto 9999 + end if + + if (lv%sm%sv%is_global()) then + if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then + lv%parms%sweeps_pre = 1 + lv%parms%sweeps_post = 1 + if (me == 0) then + write(debug_unit,*) + if (present(ilv)) then + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" at level ',ilv + write(debug_unit,*) ' is configured as a global solver ' + else + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" is configured as a global solver ' + end if + write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if - write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if end if end if - end if - - if (any((/present(amold),present(vmold),present(imold)/))) & - & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) - call psb_erractionrestore(err_act) - return + if (any((/present(amold),present(vmold),present(imold)/))) & + & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_d_base_onelev_build + end subroutine amg_d_base_onelev_build +end submodule amg_d_base_onelev_build_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_check.f90 b/amgprec/impl/level/amg_d_base_onelev_check.f90 index 468ff77a..8a196040 100644 --- a/amgprec/impl/level/amg_d_base_onelev_check.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_check.f90 @@ -35,59 +35,60 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_check(lv,info) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_check_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_check - - Implicit None - - ! Arguments - class(amg_d_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='d_base_onelev_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',ione,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',ione,is_int_non_negative) - - if (allocated(lv%sm)) then - call lv%sm%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (allocated(lv%sm2a)) then - call lv%sm2a%check(info) - else if (.not.inner_check(lv%sm2,lv%sm)) then - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return contains - function inner_check(smp,sm) result(res) - implicit none - logical :: res - class(amg_d_base_smoother_type), intent(in), pointer :: smp - class(amg_d_base_smoother_type), intent(in), target :: sm + module subroutine amg_d_base_onelev_check(lv,info) + Implicit None - res = associated(smp, sm) - end function inner_check - -end subroutine amg_d_base_onelev_check + ! Arguments + class(amg_d_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_base_onelev_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',ione,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',ione,is_int_non_negative) + + if (allocated(lv%sm)) then + call lv%sm%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (allocated(lv%sm2a)) then + call lv%sm2a%check(info) + else if (.not.inner_check(lv%sm2,lv%sm)) then + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + contains + function inner_check(smp,sm) result(res) + implicit none + logical :: res + class(amg_d_base_smoother_type), intent(in), pointer :: smp + class(amg_d_base_smoother_type), intent(in), target :: sm + + res = associated(smp, sm) + end function inner_check + + end subroutine amg_d_base_onelev_check +end submodule amg_d_base_onelev_check_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_cnv.f90 b/amgprec/impl/level/amg_d_base_onelev_cnv.f90 index ff23aafe..6ce7a230 100644 --- a/amgprec/impl/level/amg_d_base_onelev_cnv.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_cnv.f90 @@ -35,33 +35,36 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_cnv_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_cnv - implicit none - - class(amg_d_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - - integer(psb_ipk_) :: i - - info = psb_success_ - if (any((/present(amold),present(vmold),present(imold)/))) then - if (allocated(lv%sm)) & - & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%sm2a)) & - & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%wrk)) & - & call lv%wrk%cnv(info,vmold=vmold) - if (info == psb_success_.and. lv%ac%is_asb()) & - & call lv%ac%cscnv(info,mold=amold) - if (info == psb_success_ .and. lv%desc_ac%is_ok() & - & .and. present(imold)) call lv%desc_ac%cnv(imold) - if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) - end if -end subroutine amg_d_base_onelev_cnv +contains + module subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold) + + implicit none + + class(amg_d_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + + integer(psb_ipk_) :: i + + info = psb_success_ + + if (any((/present(amold),present(vmold),present(imold)/))) then + if (allocated(lv%sm)) & + & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%sm2a)) & + & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%wrk)) & + & call lv%wrk%cnv(info,vmold=vmold) + if (info == psb_success_.and. lv%ac%is_asb()) & + & call lv%ac%cscnv(info,mold=amold) + if (info == psb_success_ .and. lv%desc_ac%is_ok() & + & .and. present(imold)) call lv%desc_ac%cnv(imold) + if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) + end if + end subroutine amg_d_base_onelev_cnv +end submodule amg_d_base_onelev_cnv_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 index 493f7842..5207874a 100644 --- a/amgprec/impl/level/amg_d_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_csetc.F90 @@ -35,305 +35,309 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_csetc_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetc - use amg_d_base_aggregator_mod - use amg_d_dec_aggregator_mod - use amg_d_symdec_aggregator_mod - use amg_d_parmatch_aggregator_mod - use amg_d_poly_smoother - use amg_d_jac_smoother - use amg_d_as_smoother - use amg_d_diag_solver - use amg_d_l1_diag_solver - use amg_d_jac_solver - use amg_d_ilu_solver - use amg_d_id_solver - use amg_d_gs_solver - use amg_d_ainv_solver - use amg_d_invk_solver - use amg_d_invt_solver + +contains + module subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_d_base_aggregator_mod + use amg_d_dec_aggregator_mod + use amg_d_symdec_aggregator_mod + use amg_d_parmatch_aggregator_mod + use amg_d_poly_smoother + use amg_d_jac_smoother + use amg_d_as_smoother + use amg_d_diag_solver + use amg_d_l1_diag_solver + use amg_d_jac_solver + use amg_d_ilu_solver + use amg_d_id_solver + use amg_d_gs_solver + use amg_d_ainv_solver + use amg_d_invk_solver + use amg_d_invt_solver #if defined(AMG_HAVE_UMF) - use amg_d_umf_solver + use amg_d_umf_solver #endif #if defined(AMG_HAVE_SLUDIST) - use amg_d_sludist_solver + use amg_d_sludist_solver #endif #if defined(AMG_HAVE_SLU) - use amg_d_slu_solver + use amg_d_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_d_mumps_solver + use amg_d_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_d_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='d_base_onelev_csetc' - integer(psb_ipk_) :: ival - type(amg_d_base_smoother_type) :: amg_d_base_smoother_mold - type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold - type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold - type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold - type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold - type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold - type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold - type(amg_d_l1_jac_solver_type) :: amg_d_l1_jac_solver_mold - type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold - type(amg_d_id_solver_type) :: amg_d_id_solver_mold - type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold - type(amg_d_bwgs_solver_type) :: amg_d_bwgs_solver_mold - type(amg_d_ainv_solver_type) :: amg_d_ainv_solver_mold - type(amg_d_invk_solver_type) :: amg_d_invk_solver_mold - type(amg_d_invt_solver_type) :: amg_d_invt_solver_mold - type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold + ! Arguments + class(amg_d_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='d_base_onelev_csetc' + integer(psb_ipk_) :: ival + type(amg_d_base_smoother_type) :: amg_d_base_smoother_mold + type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold + type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold + type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold + type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold + type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold + type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold + type(amg_d_l1_jac_solver_type) :: amg_d_l1_jac_solver_mold + type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold + type(amg_d_id_solver_type) :: amg_d_id_solver_mold + type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold + type(amg_d_bwgs_solver_type) :: amg_d_bwgs_solver_mold + type(amg_d_ainv_solver_type) :: amg_d_ainv_solver_mold + type(amg_d_invk_solver_type) :: amg_d_invk_solver_mold + type(amg_d_invt_solver_type) :: amg_d_invt_solver_mold + type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold #if defined(AMG_HAVE_UMF) - type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold + type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold #endif #if defined(AMG_HAVE_SLUDIST) - type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold + type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold #endif #if defined(AMG_HAVE_SLU) - type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold + type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold + type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold #endif - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - ival = lv%stringval(val) + ival = lv%stringval(val) - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(trim(what))) - case ('SMOOTHER_TYPE') - select case (psb_toupper(trim(val))) - case ('NOPREC','NONE') - call lv%set(amg_d_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos) - - case ('JAC','JACOBI') - call lv%set(amg_d_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos) - - case ('L1-JACOBI') - call lv%set(amg_d_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) - - case ('BJAC') - call lv%set(amg_d_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - - case ('L1-BJAC') - call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - - case ('AS') - call lv%set(amg_d_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - - case ('POLY') - call lv%set(amg_d_poly_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) - case ('GS','FWGS') - call lv%set(amg_d_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('BWGS') - call lv%set(amg_d_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('FBGS') - call lv%set(amg_d_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') - call lv%set(amg_d_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post') - case ('L1-GS','L1-FWGS') - call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-BWGS') - call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-FBGS') - call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') - call lv%set(amg_d_l1_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(trim(what))) + case ('SMOOTHER_TYPE') + select case (psb_toupper(trim(val))) + case ('NOPREC','NONE') + call lv%set(amg_d_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (psb_toupper(trim(val))) - case ('NONE','NOPREC','FACT_NONE') - call lv%set(amg_d_id_solver_mold,info,pos=pos) + case ('JAC','JACOBI') + call lv%set(amg_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') - call lv%set(amg_d_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') - call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) + case ('BJAC') + call lv%set(amg_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - case ('GS','FGS','FWGS') - call lv%set(amg_d_gs_solver_mold,info,pos=pos) + case ('L1-BJAC') + call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - case ('BGS','BWGS') - call lv%set(amg_d_bwgs_solver_mold,info,pos=pos) + case ('AS') + call lv%set(amg_d_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - case ('AINV') - call lv%set(amg_d_ainv_solver_mold,info,pos=pos) - case ('INVK') - call lv%set(amg_d_invk_solver_mold,info,pos=pos) - case ('INVT') - call lv%set(amg_d_invt_solver_mold,info,pos=pos) - case ('ILU','ILUT','MILU') - call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case ('POLY') + call lv%set(amg_d_poly_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) + case ('GS','FWGS') + call lv%set(amg_d_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('BWGS') + call lv%set(amg_d_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('FBGS') + call lv%set(amg_d_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') + call lv%set(amg_d_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post') + case ('L1-GS','L1-FWGS') + call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-BWGS') + call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-FBGS') + call lv%set(amg_d_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') + call lv%set(amg_d_l1_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (psb_toupper(trim(val))) + case ('NONE','NOPREC','FACT_NONE') + call lv%set(amg_d_id_solver_mold,info,pos=pos) + + case ('DIAG','JACOBI') + call lv%set(amg_d_diag_solver_mold,info,pos=pos) + + case ('L1-DIAG','L1-JACOBI') + call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) + + case ('GS','FGS','FWGS') + call lv%set(amg_d_gs_solver_mold,info,pos=pos) + + case ('BGS','BWGS') + call lv%set(amg_d_bwgs_solver_mold,info,pos=pos) + + case ('AINV') + call lv%set(amg_d_ainv_solver_mold,info,pos=pos) + case ('INVK') + call lv%set(amg_d_invk_solver_mold,info,pos=pos) + case ('INVT') + call lv%set(amg_d_invt_solver_mold,info,pos=pos) + case ('ILU','ILUT','MILU') + call lv%set(amg_d_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case ('SLU') - call lv%set(amg_d_slu_solver_mold,info,pos=pos) + case ('SLU') + call lv%set(amg_d_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case ('MUMPS') - call lv%set(amg_d_mumps_solver_mold,info,pos=pos) + case ('MUMPS') + call lv%set(amg_d_mumps_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_SLUDIST - case ('SLUDIST') - call lv%set(amg_d_sludist_solver_mold,info,pos=pos) + case ('SLUDIST') + call lv%set(amg_d_sludist_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_UMF - case ('UMF') - call lv%set(amg_d_umf_solver_mold,info,pos=pos) + case ('UMF') + call lv%set(amg_d_umf_solver_mold,info,pos=pos) #endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select + case default + ! + ! Do nothing and hope for the best :) + ! + end select - case ('ML_CYCLE') - lv%parms%ml_cycle = amg_stringval(val) + case ('ML_CYCLE') + lv%parms%ml_cycle = amg_stringval(val) - case ('PAR_AGGR_ALG') - ival = amg_stringval(val) - lv%parms%par_aggr_alg = ival - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='aggregator deallocation?') + case ('PAR_AGGR_ALG') + ival = amg_stringval(val) + lv%parms%par_aggr_alg = ival + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='aggregator deallocation?') + goto 9999 + return + end if + end if + + select case(val) + case('DEC','DECOUPLED') + allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info) + case('SYMDEC') + allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info) + case('COUP','COUPLED') + allocate(amg_d_parmatch_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') goto 9999 - return - end if - end if + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = amg_stringval(val) + + case ('AGGR_TYPE') + lv%parms%aggr_type = amg_stringval(val) + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = amg_stringval(val) + + case ('COARSE_MAT') + lv%parms%coarse_mat = amg_stringval(val) + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= amg_stringval(val) + + case ('AGGR_EIG') + lv%parms%aggr_eig = amg_stringval(val) + + case ('AGGR_FILTER') + lv%parms%aggr_filter = amg_stringval(val) + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = amg_stringval(val) + + case default + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - select case(val) - case('DEC','DECOUPLED') - allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info) - case('SYMDEC') - allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info) - case('COUP','COUPLED') - allocate(amg_d_parmatch_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') - goto 9999 end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = amg_stringval(val) - - case ('AGGR_TYPE') - lv%parms%aggr_type = amg_stringval(val) - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = amg_stringval(val) - - case ('COARSE_MAT') - lv%parms%coarse_mat = amg_stringval(val) - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= amg_stringval(val) - - case ('AGGR_EIG') - lv%parms%aggr_eig = amg_stringval(val) - - case ('AGGR_FILTER') - lv%parms%aggr_filter = amg_stringval(val) - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = amg_stringval(val) - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_d_base_onelev_csetc + end subroutine amg_d_base_onelev_csetc +end submodule amg_d_base_onelev_csetc_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_cseti.F90 b/amgprec/impl/level/amg_d_base_onelev_cseti.F90 index a23ccf99..315478bb 100644 --- a/amgprec/impl/level/amg_d_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_cseti.F90 @@ -35,255 +35,259 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_cseti_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_cseti - use amg_d_base_aggregator_mod - use amg_d_dec_aggregator_mod - use amg_d_symdec_aggregator_mod - use amg_d_parmatch_aggregator_mod - use amg_d_jac_smoother - use amg_d_as_smoother - use amg_d_diag_solver - use amg_d_l1_diag_solver - use amg_d_ilu_solver - use amg_d_id_solver - use amg_d_gs_solver + +contains + module subroutine amg_d_base_onelev_cseti(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_d_base_aggregator_mod + use amg_d_dec_aggregator_mod + use amg_d_symdec_aggregator_mod + use amg_d_parmatch_aggregator_mod + use amg_d_jac_smoother + use amg_d_as_smoother + use amg_d_diag_solver + use amg_d_l1_diag_solver + use amg_d_ilu_solver + use amg_d_id_solver + use amg_d_gs_solver #if defined(AMG_HAVE_UMF) - use amg_d_umf_solver + use amg_d_umf_solver #endif #if defined(AMG_HAVE_SLUDIST) - use amg_d_sludist_solver + use amg_d_sludist_solver #endif #if defined(AMG_HAVE_SLU) - use amg_d_slu_solver + use amg_d_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_d_mumps_solver + use amg_d_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_d_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='d_base_onelev_cseti' - type(amg_d_base_smoother_type) :: amg_d_base_smoother_mold - type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold - type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold - type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold - type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold - type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold - type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold - type(amg_d_id_solver_type) :: amg_d_id_solver_mold - type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold - type(amg_d_bwgs_solver_type) :: amg_d_bwgs_solver_mold + ! Arguments + class(amg_d_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='d_base_onelev_cseti' + type(amg_d_base_smoother_type) :: amg_d_base_smoother_mold + type(amg_d_jac_smoother_type) :: amg_d_jac_smoother_mold + type(amg_d_l1_jac_smoother_type) :: amg_d_l1_jac_smoother_mold + type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold + type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold + type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold + type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold + type(amg_d_id_solver_type) :: amg_d_id_solver_mold + type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold + type(amg_d_bwgs_solver_type) :: amg_d_bwgs_solver_mold #if defined(AMG_HAVE_UMF) - type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold + type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold #endif #if defined(AMG_HAVE_SLUDIST) - type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold + type(amg_d_sludist_solver_type) :: amg_d_sludist_solver_mold #endif #if defined(AMG_HAVE_SLU) - type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold + type(amg_d_slu_solver_type) :: amg_d_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold + type(amg_d_mumps_solver_type) :: amg_d_mumps_solver_mold #endif - call psb_erractionsave(err_act) - info = psb_success_ + call psb_erractionsave(err_act) + info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(what)) - case ('SMOOTHER_TYPE') - select case (val) - case (amg_noprec_) - call lv%set(amg_d_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos) - - case (amg_jac_) - call lv%set(amg_d_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos) - - case (amg_l1_jac_) - call lv%set(amg_d_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) - - case (amg_bjac_) - call lv%set(amg_d_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - - case (amg_l1_bjac_) - call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - - case (amg_as_) - call lv%set(amg_d_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - - case (amg_fbgs_) - call lv%set(amg_d_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') - call lv%set(amg_d_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (amg_noprec_) + call lv%set(amg_d_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (val) - case (amg_f_none_) - call lv%set(amg_d_id_solver_mold,info,pos=pos) + case (amg_jac_) + call lv%set(amg_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_diag_solver_mold,info,pos=pos) - case (amg_diag_scale_) - call lv%set(amg_d_diag_solver_mold,info,pos=pos) + case (amg_l1_jac_) + call lv%set(amg_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) - case (amg_l1_diag_scale_) - call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) + case (amg_bjac_) + call lv%set(amg_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - case (amg_gs_) - call lv%set(amg_d_gs_solver_mold,info,pos=pos) + case (amg_l1_bjac_) + call lv%set(amg_d_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - case (amg_bwgs_) - call lv%set(amg_d_bwgs_solver_mold,info,pos=pos) + case (amg_as_) + call lv%set(amg_d_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) - call lv%set(amg_d_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case (amg_fbgs_) + call lv%set(amg_d_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre') + call lv%set(amg_d_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_d_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (val) + case (amg_f_none_) + call lv%set(amg_d_id_solver_mold,info,pos=pos) + + case (amg_diag_scale_) + call lv%set(amg_d_diag_solver_mold,info,pos=pos) + + case (amg_l1_diag_scale_) + call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos) + + case (amg_gs_) + call lv%set(amg_d_gs_solver_mold,info,pos=pos) + + case (amg_bwgs_) + call lv%set(amg_d_bwgs_solver_mold,info,pos=pos) + + case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) + call lv%set(amg_d_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case (amg_slu_) - call lv%set(amg_d_slu_solver_mold,info,pos=pos) + case (amg_slu_) + call lv%set(amg_d_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case (amg_mumps_) - call lv%set(amg_d_mumps_solver_mold,info,pos=pos) + case (amg_mumps_) + call lv%set(amg_d_mumps_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_SLUDIST - case (amg_sludist_) - call lv%set(amg_d_sludist_solver_mold,info,pos=pos) + case (amg_sludist_) + call lv%set(amg_d_sludist_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_UMF - case (amg_umf_) - call lv%set(amg_d_umf_solver_mold,info,pos=pos) + case (amg_umf_) + call lv%set(amg_d_umf_solver_mold,info,pos=pos) #endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_pre = val + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_post = val + + case ('ML_CYCLE') + lv%parms%ml_cycle = val + + case ('PAR_AGGR_ALG') + lv%parms%par_aggr_alg = val + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + return + end if + end if + + select case(val) + case(amg_dec_aggr_) + allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info) + case(amg_sym_dec_aggr_) + allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_TYPE') + lv%parms%aggr_type = val + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + case default - ! - ! Do nothing and hope for the best :) - ! + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + end select - - - case ('SMOOTHER_SWEEPS') - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_pre = val - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_post = val - - case ('ML_CYCLE') - lv%parms%ml_cycle = val - - case ('PAR_AGGR_ALG') - lv%parms%par_aggr_alg = val - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - return - end if - end if - - select case(val) - case(amg_dec_aggr_) - allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info) - case(amg_sym_dec_aggr_) - allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = val - - case ('AGGR_TYPE') - lv%parms%aggr_type = val - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = val - - case ('COARSE_MAT') - lv%parms%coarse_mat = val - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= val - - case ('AGGR_EIG') - lv%parms%aggr_eig = val - - case ('AGGR_FILTER') - lv%parms%aggr_filter = val - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = val - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_d_base_onelev_cseti + end subroutine amg_d_base_onelev_cseti +end submodule amg_d_base_onelev_cseti_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_csetr.f90 b/amgprec/impl/level/amg_d_base_onelev_csetr.f90 index 819cc6ec..dbcb84e8 100644 --- a/amgprec/impl/level/amg_d_base_onelev_csetr.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_csetr.f90 @@ -35,71 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_csetr_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_csetr + +contains + module subroutine amg_d_base_onelev_csetr(lv,what,val,info,pos,idx) - Implicit None + Implicit None - ! Arguments - class(amg_d_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='d_base_onelev_csetr' + ! Arguments + class(amg_d_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='d_base_onelev_csetr' - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - select case (psb_toupper(what)) + select case (psb_toupper(what)) - case ('AGGR_OMEGA_VAL') - lv%parms%aggr_omega_val= val + case ('AGGR_OMEGA_VAL') + lv%parms%aggr_omega_val= val - case ('AGGR_THRESH') - lv%parms%aggr_thresh = val + case ('AGGR_THRESH') + lv%parms%aggr_thresh = val - case default - - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + case default + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) + + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - end select + end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_d_base_onelev_csetr + end subroutine amg_d_base_onelev_csetr +end submodule amg_d_base_onelev_csetr_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_descr.f90 b/amgprec/impl/level/amg_d_base_onelev_descr.f90 index 000c5b59..6e6b40d7 100644 --- a/amgprec/impl/level/amg_d_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_descr.f90 @@ -42,114 +42,116 @@ ! 0: normal ! >1: increased details ! -subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_descr_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_descr - Implicit None - ! Arguments - class(amg_d_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - integer(psb_ipk_), intent(in), optional :: verbosity - character(len=*), intent(in), optional :: prefix - - - ! Local variables - integer(psb_ipk_) :: err_act - character(len=20), parameter :: name='amg_d_base_onelev_descr' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse - character(1024) :: prefix_ - type(psb_ctxt_type) :: pctxt - integer(psb_ipk_) :: pme, pnp - - - call psb_erractionsave(err_act) - - - coarse = (il==nl) - - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - - pctxt = lv%desc_ac%get_ctxt() - call psb_info(pctxt,pme,pnp) - write(iout_,*) trim(prefix_) - write(iout_,*) 'At level :',il,' we have ',pnp,' processes' - write(iout_,*) trim(prefix_) - if (il == ilmin) then - call lv%parms%mlcycledsc(iout_,info) - end if - if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then - if (allocated(lv%aggr)) then - call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) - else - write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 +contains + module subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) + Implicit None + ! Arguments + class(amg_d_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_d_base_onelev_descr' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp + + + call psb_erractionsave(err_act) + + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 + end if + if (verbosity_ < 0) goto 9998 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) write(iout_,*) trim(prefix_) - end if - - if (il > 1) then - - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' + write(iout_,*) trim(prefix_) + if (il == ilmin) then + call lv%parms%mlcycledsc(iout_,info) end if - - call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) - - if (nl > 1) then - if (allocated(lv%linmap%naggr)) then - write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & - & lv%linmap%nagtot - write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot - if (verbosity_>0) then - write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & - & lv%linmap%naggr(:) - else - write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& - & ' Local matrix sizes: min:', & - & lv%linmap%nagmin,' max:', lv%linmap%nagmax - write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& - & ' avg:', & - & lv%linmap%nagavg - end if - write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& - & ' Aggregation ratio: ', & - & lv%szratio + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then + if (allocated(lv%aggr)) then + call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) + else + write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 end if + write(iout_,*) trim(prefix_) end if - if (coarse.and.allocated(lv%sm)) & - & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) - end if + if (il > 1) then + + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + + call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) + + if (nl > 1) then + if (allocated(lv%linmap%naggr)) then + write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & + & lv%linmap%nagtot + write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot + if (verbosity_>0) then + write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & + & lv%linmap%naggr(:) + else + write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& + & ' Local matrix sizes: min:', & + & lv%linmap%nagmin,' max:', lv%linmap%nagmax + write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& + & ' avg:', & + & lv%linmap%nagavg + end if + write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& + & ' Aggregation ratio: ', & + & lv%szratio + end if + end if + + if (coarse.and.allocated(lv%sm)) & + & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) + end if 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_d_base_onelev_descr + end subroutine amg_d_base_onelev_descr +end submodule amg_d_base_onelev_descr_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_dump.f90 b/amgprec/impl/level/amg_d_base_onelev_dump.f90 index 4c698dff..649c3aec 100644 --- a/amgprec/impl/level/amg_d_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_dump.f90 @@ -35,135 +35,137 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& - & smoother,solver,tprol,global_num) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_dump_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_dump - implicit none - class(amg_d_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: level - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num - ! Local variables - integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np - character(len=80) :: prefix_, frmt - character(len=1024) :: fname - logical :: ac_, rp_, tprol_, global_num_ - integer(psb_lpk_), allocatable :: ivr(:), ivc(:) - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_lev_d" - end if - - if (associated(lv%base_desc)) then - ctxt = lv%base_desc%get_context() - call psb_info(ctxt,iam,np) - else - iam = -1 - np = -1 - end if - if (present(ac)) then - ac_ = ac - else - ac_ = .false. - end if - if (present(rp)) then - rp_ = rp - else - rp_ = .false. - end if - if (present(tprol)) then - tprol_ = tprol - else - tprol_ = .false. - end if - if (present(global_num)) then - global_num_ = global_num - else - global_num_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - - if (np > 0) then - ni = floor(log10(1.0*np)) + 1 - write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' - write(fname(lname+1:lname+ni+2),frmt) '_p',iam - lname = lname + ni + 2 - end if - - if (global_num_) then - if (level == 1) then - if (ac_) then - ivr = lv%base_desc%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head,iv=ivr) - end if - else if (level >= 2) then - if (ac_) then - ivr = lv%desc_ac%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head,iv=ivr) - end if - if (rp_) then - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) - end if - if (tprol_) then - ! Tentative prolongator is stored with column indices already - ! in global numbering, so only IVR is needed. - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head,ivr=ivr) - end if - end if - else - if (level == 1) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head) - end if - else if (level >= 2) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head) - end if - if (rp_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head) - end if - if (tprol_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head) - end if - end if - end if - if (level >= 1) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) +contains + module subroutine amg_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& + & smoother,solver,tprol,global_num) + implicit none + class(amg_d_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num + ! Local variables + integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_, frmt + character(len=1024) :: fname + logical :: ac_, rp_, tprol_, global_num_ + integer(psb_lpk_), allocatable :: ivr(:), ivc(:) + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_lev_d" end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + + if (associated(lv%base_desc)) then + ctxt = lv%base_desc%get_context() + call psb_info(ctxt,iam,np) + else + iam = -1 + np = -1 end if - end if - -end subroutine amg_d_base_onelev_dump + if (present(ac)) then + ac_ = ac + else + ac_ = .false. + end if + if (present(rp)) then + rp_ = rp + else + rp_ = .false. + end if + if (present(tprol)) then + tprol_ = tprol + else + tprol_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + + if (np > 0) then + ni = floor(log10(1.0*np)) + 1 + write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' + write(fname(lname+1:lname+ni+2),frmt) '_p',iam + lname = lname + ni + 2 + end if + + if (global_num_) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then + if (ac_) then + ivr = lv%desc_ac%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head,iv=ivr) + end if + if (rp_) then + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) + end if + if (tprol_) then + ! Tentative prolongator is stored with column indices already + ! in global numbering, so only IVR is needed. + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head,ivr=ivr) + end if + end if + else + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head) + end if + if (rp_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head) + end if + if (tprol_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head) + end if + end if + end if + + if (level >= 1) then + if (allocated(lv%sm)) then + call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) + end if + if (allocated(lv%sm2a)) then + call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + end if + end if + + end subroutine amg_d_base_onelev_dump +end submodule amg_d_base_onelev_dump_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_free.f90 b/amgprec/impl/level/amg_d_base_onelev_free.f90 index 2ecb9e84..b5bf3cdb 100644 --- a/amgprec/impl/level/amg_d_base_onelev_free.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_free.f90 @@ -35,41 +35,43 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_free(lv,info) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_free_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_free - implicit none + +contains + module subroutine amg_d_base_onelev_free(lv,info) + implicit none - class(amg_d_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_d_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) - if (allocated(lv%wrk)) & - & call lv%wrk%free(info) + if (allocated(lv%wrk)) & + & call lv%wrk%free(info) - call lv%ac%free() - if (lv%desc_ac%is_ok()) & - & call lv%desc_ac%free(info) - call lv%linmap%free(info) + call lv%ac%free() + if (lv%desc_ac%is_ok()) & + & call lv%desc_ac%free(info) + call lv%linmap%free(info) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_a) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_desc) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_a) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_desc) - call lv%nullify() + call lv%nullify() -end subroutine amg_d_base_onelev_free + end subroutine amg_d_base_onelev_free +end submodule amg_d_base_onelev_free_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_free_smoothers.f90 b/amgprec/impl/level/amg_d_base_onelev_free_smoothers.f90 index ac0367df..351b4192 100644 --- a/amgprec/impl/level/amg_d_base_onelev_free_smoothers.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_free_smoothers.f90 @@ -35,26 +35,28 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_free_smoothers(lv,info) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_dree_smoothers_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_free_smoothers - implicit none + +contains + module subroutine amg_d_base_onelev_free_smoothers(lv,info) + implicit none - class(amg_d_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_d_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) -end subroutine amg_d_base_onelev_free_smoothers + end subroutine amg_d_base_onelev_free_smoothers +end submodule amg_d_base_onelev_dree_smoothers_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_map_prol.F90 b/amgprec/impl/level/amg_d_base_onelev_map_prol.F90 index 4dc7ea84..a96b0f0d 100644 --- a/amgprec/impl/level/amg_d_base_onelev_map_prol.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_map_prol.F90 @@ -35,112 +35,113 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_prol_v - - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_d_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), optional :: work(:) - type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_d_vect_type), pointer :: vtx_ +submodule (amg_d_onelev_mod) amg_d_base_onelev_map_prol_impl + use psb_base_mod + +contains + module subroutine amg_d_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_d_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional :: work(:) + type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty + + type(psb_d_vect_type), pointer :: vtx_ !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vtx)) then - vtx_ => vtx - else - vtx_ => lv%wrk%wv(1) - end if - -!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! -!!$ write(0,*) 'Remap handling ' - block - type(psb_ctxt_type) :: ctxt, nctxt - integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp - integer(psb_mpk_) :: me, np, rme, rnp - real(psb_dpk_), allocatable :: rsnd(:), rrcv(:) - type(psb_d_vect_type) :: tv + if (present(vtx)) then + vtx_ => vtx + else + vtx_ => lv%wrk%wv(1) + end if - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) +!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! +!!$ write(0,*) 'Remap handling ' + block + type(psb_ctxt_type) :: ctxt, nctxt + integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp + integer(psb_mpk_) :: me, np, rme, rnp +real(psb_dpk_), allocatable :: rsnd(:), rrcv(:) + type(psb_d_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal() - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + nctxt = lv%desc_ac%get_ctxt() + call psb_info(nctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal() - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal() - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) - rrcv = vect_v%get_vect() + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) + rrcv = vect_v%get_vect() !!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl - call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - end if - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + end if + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) !!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal() - - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info !!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal() !!$ call psb_realloc(nrc,rsnd,info) !!$ call psb_rcv(ctxt,rsnd(1:nrl),idest) !!$ call tv%set_vect(rsnd) - call psb_rcv(ctxt,tv%v%v(1:nrl),idest) - call tv%set_host() - call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end associate + call psb_rcv(ctxt,tv%v%v(1:nrl),idest) + call tv%set_host() + call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end associate !!$ write(0,*) me, ' Prolongator with remap done ' !!$ flush(0) !!$ call psb_barrier(ctxt) - end block - else - ! Default transfer - call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end if - -end subroutine amg_d_base_onelev_map_prol_v + end block + else + ! Default transfer + call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end if -subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_prol_a - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv - real(psb_dpk_), intent(in) :: alpha, beta - real(psb_dpk_), intent(inout) :: u(:) - real(psb_dpk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), optional :: work(:) + end subroutine amg_d_base_onelev_map_prol_v - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap P handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_V2U(alpha,v,beta,u,info,& - & work=work) - end if - -end subroutine amg_d_base_onelev_map_prol_a + module subroutine amg_d_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + real(psb_dpk_), intent(in) :: alpha, beta + real(psb_dpk_), intent(inout) :: u(:) + real(psb_dpk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional :: work(:) + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap P handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_V2U(alpha,v,beta,u,info,& + & work=work) + end if + + end subroutine amg_d_base_onelev_map_prol_a +end submodule amg_d_base_onelev_map_prol_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 index ecb9d4cb..39532a5b 100644 --- a/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 @@ -36,114 +36,115 @@ ! ! -subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& - & work,vtx,vty) +submodule (amg_d_onelev_mod) amg_d_base_onelev_map_rstr_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_rstr_v - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_d_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), optional :: work(:) - type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_d_vect_type), pointer :: vty_ - integer(psb_mpk_) :: me, np + +contains + module subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_d_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional :: work(:) + type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty + type(psb_d_vect_type), pointer :: vty_ + integer(psb_mpk_) :: me, np !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vty)) then - vty_ => vty - else - vty_ => lv%wrk%wv(1) - end if - - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! + if (present(vty)) then + vty_ => vty + else + vty_ => lv%wrk%wv(1) + end if + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! !!$ write(0,*) 'Remap handling not implemented yet ' - block - type(psb_ctxt_type) :: ctxt, rctxt - integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp - integer(psb_mpk_) :: rme, rnp - real(psb_dpk_), allocatable :: rsnd(:), rrcv(:) - type(psb_d_vect_type) :: tv - - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) - rctxt = lv%desc_ac%get_ctxt() - call psb_info(rctxt,rme,rnp) + block + type(psb_ctxt_type) :: ctxt, rctxt + integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp + integer(psb_mpk_) :: rme, rnp +real(psb_dpk_), allocatable :: rsnd(:), rrcv(:) + type(psb_d_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context map rstr',rme,rnp,me,np - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest !!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:) - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),& !!$ & psb_errstatus_fatal() !!$ flush(0) - call psb_barrier(ctxt) - call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& - & work=work,vtx=vtx,vty=vty_) - call tv%sync() - !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + call psb_barrier(ctxt) + call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& + & work=work,vtx=vtx,vty=vty_) + call tv%sync() + !rsnd = tv%get_vect() + !call psb_snd(ctxt,rsnd(1:nrl),idest) !!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal() - call psb_snd(ctxt,tv%v%v(1:nrl),idest) - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) + call psb_snd(ctxt,tv%v%v(1:nrl),idest) + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) !!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal() - call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - call vect_v%set_vect(rrcv) - end if - end associate + call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + call vect_v%set_vect(rrcv) + end if + end associate !!$ write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal() - end block - - else - ! Default transfer - block - type(psb_ctxt_type) :: ctxt, rctxt - ctxt = lv%linmap%p_desc_U%get_ctxt() - call psb_info(ctxt,me,np) + end block + + else + ! Default transfer + block + type(psb_ctxt_type) :: ctxt, rctxt + ctxt = lv%linmap%p_desc_U%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) me,' map_rstr calling U2V: ',me,np - call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& - & work=work,vtx=vtx,vty=vty_) - end block - end if + call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& + & work=work,vtx=vtx,vty=vty_) + end block + end if !!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal() -end subroutine amg_d_base_onelev_map_rstr_v + end subroutine amg_d_base_onelev_map_rstr_v -subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_map_rstr_a - implicit none - class(amg_d_onelev_type), target, intent(inout) :: lv - real(psb_dpk_), intent(in) :: alpha, beta - real(psb_dpk_), intent(inout) :: u(:) - real(psb_dpk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), optional :: work(:) + module subroutine amg_d_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + real(psb_dpk_), intent(in) :: alpha, beta + real(psb_dpk_), intent(inout) :: u(:) + real(psb_dpk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional :: work(:) - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap R handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_U2V(alpha,u,beta,v,info,& - & work=work) - end if - -end subroutine amg_d_base_onelev_map_rstr_a + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap R handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_U2V(alpha,u,beta,v,info,& + & work=work) + end if + + end subroutine amg_d_base_onelev_map_rstr_a +end submodule amg_d_base_onelev_map_rstr_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_mat_asb.f90 b/amgprec/impl/level/amg_d_base_onelev_mat_asb.f90 index 7f94407a..69fe2ddd 100644 --- a/amgprec/impl/level/amg_d_base_onelev_mat_asb.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_mat_asb.f90 @@ -83,109 +83,111 @@ ! info - integer, output. ! Error code. ! -subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_mat_asb_impl use psb_base_mod use amg_base_prec_type - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_mat_asb - - implicit none - - ! Arguments - class(amg_d_onelev_type), intent(inout), target :: lv - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(inout) :: desc_a - integer(psb_lpk_), intent(inout) :: nlaggr(:) - integer(psb_lpk_), intent(inout) :: ilaggr(:) - type(psb_ldspmat_type), intent(inout) :: t_prol - integer(psb_ipk_), intent(out) :: info +contains + module subroutine amg_d_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - ! Local variables - character(len=24) :: name - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - type(psb_dspmat_type) :: ac, op_restr, op_prol - integer(psb_ipk_) :: nzl, inl - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 - logical, parameter :: do_timings=.false. + implicit none - name='amg_d_onelev_mat_asb' - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - info = psb_success_ - ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) - if ((do_timings).and.(idx_matbld==-1)) & - & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") - if ((do_timings).and.(idx_matasb==-1)) & - & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") - if ((do_timings).and.(idx_mapbld==-1)) & - & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - - call amg_check_def(lv%parms%aggr_prol,'Smoother',& - & amg_smooth_prol_,is_legal_ml_aggr_prol) - call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& - & amg_distr_mat_,is_legal_ml_coarse_mat) - call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& - & amg_no_filter_mat_,is_legal_aggr_filter) - call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& - & amg_eig_est_,is_legal_ml_aggr_omega_alg) - call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& - & amg_max_norm_,is_legal_ml_aggr_eig) - call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + ! Arguments + class(amg_d_onelev_type), intent(inout), target :: lv + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(inout) :: nlaggr(:) + integer(psb_lpk_), intent(inout) :: ilaggr(:) + type(psb_ldspmat_type), intent(inout) :: t_prol + integer(psb_ipk_), intent(out) :: info - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by lv%iprcparm(amg_aggr_prol_) - ! - if (do_timings) call psb_tic(idx_matbld) - call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& - & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) - if (do_timings) call psb_toc(idx_matbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') - goto 9999 - end if + ! Local variables + character(len=24) :: name + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + type(psb_dspmat_type) :: ac, op_restr, op_prol + integer(psb_ipk_) :: nzl, inl + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 + logical, parameter :: do_timings=.false. - ! - ! Now build its descriptor and convert global indices for - ! ac, op_restr and op_prol - ! - if (do_timings) call psb_tic(idx_matasb) - if (info == psb_success_) & - & call lv%aggr%mat_asb(lv%parms,a,desc_a,& - & lv%ac,lv%desc_ac,op_prol,op_restr,info) - if (do_timings) call psb_toc(idx_matasb) - if (do_timings) call psb_tic(idx_mapbld) - if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - - if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& - & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) - if (do_timings) call psb_toc(idx_mapbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') - goto 9999 - end if - ! - ! Fix the base_a and base_desc pointers for handling of residuals. - ! This is correct because this routine is only called at levels >=2. - ! - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac + name='amg_d_onelev_mat_asb' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if ((do_timings).and.(idx_matbld==-1)) & + & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") + if ((do_timings).and.(idx_matasb==-1)) & + & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") + if ((do_timings).and.(idx_mapbld==-1)) & + & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - call psb_erractionrestore(err_act) - return + call amg_check_def(lv%parms%aggr_prol,'Smoother',& + & amg_smooth_prol_,is_legal_ml_aggr_prol) + call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& + & amg_distr_mat_,is_legal_ml_coarse_mat) + call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& + & amg_no_filter_mat_,is_legal_aggr_filter) + call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& + & amg_eig_est_,is_legal_ml_aggr_omega_alg) + call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& + & amg_max_norm_,is_legal_ml_aggr_eig) + call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by lv%iprcparm(amg_aggr_prol_) + ! + if (do_timings) call psb_tic(idx_matbld) + call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& + & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) + if (do_timings) call psb_toc(idx_matbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') + goto 9999 + end if + + ! + ! Now build its descriptor and convert global indices for + ! ac, op_restr and op_prol + ! + if (do_timings) call psb_tic(idx_matasb) + if (info == psb_success_) & + & call lv%aggr%mat_asb(lv%parms,a,desc_a,& + & lv%ac,lv%desc_ac,op_prol,op_restr,info) + if (do_timings) call psb_toc(idx_matasb) + if (do_timings) call psb_tic(idx_mapbld) + if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + + if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& + & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) + if (do_timings) call psb_toc(idx_mapbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') + goto 9999 + end if + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_d_base_onelev_mat_asb + end subroutine amg_d_base_onelev_mat_asb +end submodule amg_d_base_onelev_mat_asb_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 index a9f6a923..df1ffe80 100644 --- a/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_memory_use.f90 @@ -42,109 +42,112 @@ ! 0: normal ! >1: increased details ! -subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_memory_use_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_memory_use - Implicit None - ! Arguments - class(amg_d_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - character(len=*), intent(in), optional :: prefix - integer(psb_ipk_), intent(in), optional :: verbosity - logical, intent(in), optional :: global - - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: err_act ,me, np - character(len=20), parameter :: name='amg_d_base_onelev_memory_use' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse, global_ - character(1024) :: prefix_ - integer(psb_epk_), allocatable :: sz(:) - - - call psb_erractionsave(err_act) - - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - coarse = (il==nl) +contains + module subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity,prefix,global) + Implicit None + ! Arguments + class(amg_d_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + character(len=*), intent(in), optional :: prefix + integer(psb_ipk_), intent(in), optional :: verbosity + logical, intent(in), optional :: global - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(global)) then - global_ = global - else - global_ = .true. - end if + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act ,me, np + character(len=20), parameter :: name='amg_d_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse, global_ + character(1024) :: prefix_ + integer(psb_epk_), allocatable :: sz(:) - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + call psb_erractionsave(err_act) - if (global_) then - allocate(sz(6)) - sz(:) = 0 - sz(1) = lv%base_a%sizeof() - sz(2) = lv%base_desc%sizeof() - if (il >1) sz(3) = lv%linmap%sizeof() - if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() - if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() - if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() - call psb_sum(ctxt,sz) - if (me == 0) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', sz(1) - write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if - - else - if ((me == 0).or.(verbosity_>0)) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() - write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 end if - endif + if (verbosity_ < 0) goto 9998 + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + + if (global_) then + allocate(sz(6)) + sz(:) = 0 + sz(1) = lv%base_a%sizeof() + sz(2) = lv%base_desc%sizeof() + if (il >1) sz(3) = lv%linmap%sizeof() + if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() + if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() + if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() + call psb_sum(ctxt,sz) + if (me == 0) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', sz(1) + write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + end if + + else + if ((me == 0).or.(verbosity_>0)) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() + write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + end if + endif 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_d_base_onelev_memory_use + end subroutine amg_d_base_onelev_memory_use +end submodule amg_d_base_onelev_memory_use_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_setag.f90 b/amgprec/impl/level/amg_d_base_onelev_setag.f90 index 70d10630..d81366af 100644 --- a/amgprec/impl/level/amg_d_base_onelev_setag.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_setag.f90 @@ -35,48 +35,50 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_setag(lv,val,info,pos) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_setag_impl use psb_base_mod - use amg_d_onelev_mod, amg_protect_name => amg_d_base_onelev_setag - - implicit none - - ! Arguments - class(amg_d_onelev_type), target, intent(inout) :: lv - class(amg_d_base_aggregator_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setag' +contains + module subroutine amg_d_base_onelev_setag(lv,val,info,pos) - info = psb_success_ + implicit none - ! Ignore pos for aggregator - - if (allocated(lv%aggr)) then - if (.not.same_type_as(lv%aggr,val)) then - call lv%aggr%free(info) - deallocate(lv%aggr,stat=info) + ! Arguments + class(amg_d_onelev_type), target, intent(inout) :: lv + class(amg_d_base_aggregator_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setag' + + info = psb_success_ + + ! Ignore pos for aggregator + + if (allocated(lv%aggr)) then + if (.not.same_type_as(lv%aggr,val)) then + call lv%aggr%free(info) + deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%aggr)) then + allocate(lv%aggr,mold=val,stat=info) if (info /= 0) then info = 3111 return end if + lv%parms%par_aggr_alg = amg_ext_aggr_ + lv%parms%aggr_type = amg_noalg_ + call lv%aggr%default() end if - end if - - if (.not.allocated(lv%aggr)) then - allocate(lv%aggr,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - lv%parms%par_aggr_alg = amg_ext_aggr_ - lv%parms%aggr_type = amg_noalg_ - call lv%aggr%default() - end if - -end subroutine amg_d_base_onelev_setag + end subroutine amg_d_base_onelev_setag + +end submodule amg_d_base_onelev_setag_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_setsm.F90 b/amgprec/impl/level/amg_d_base_onelev_setsm.F90 index f534e4f0..b5f69265 100644 --- a/amgprec/impl/level/amg_d_base_onelev_setsm.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_setsm.F90 @@ -35,72 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_setsm(lev,val,info,pos) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_setsm_impl use psb_base_mod - use amg_d_prec_mod, amg_protect_name => amg_d_base_onelev_setsm - - implicit none - - ! Arguments - class(amg_d_onelev_type), target, intent(inout) :: lev - class(amg_d_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsm' - - info = psb_success_ +contains + module subroutine amg_d_base_onelev_setsm(lv,val,info,pos) + implicit none - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Arguments + class(amg_d_onelev_type), target, intent(inout) :: lv + class(amg_d_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if (ipos_ == amg_smooth_both_) then - if (allocated(lev%sm2a)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - lev%sm2 => null() end if - end if - - select case(ipos_) - case(amg_smooth_pre_, amg_smooth_both_) - if (allocated(lev%sm)) then - if (.not.same_type_as(lev%sm,val)) then - call lev%sm%free(info) - deallocate(lev%sm, stat=info) + + if (ipos_ == amg_smooth_both_) then + if (allocated(lv%sm2a)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + lv%sm2 => null() end if - endif - if (.not.allocated(lev%sm)) then - allocate(lev%sm,mold=val) end if - call lev%sm%default() - if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm - case(amg_smooth_post_) - if (allocated(lev%sm2a)) then - if (.not.same_type_as(lev%sm2a,val)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - endif - end if - if (.not.allocated(lev%sm2a)) then - allocate(lev%sm2a,mold=val) - end if - call lev%sm2a%default() - lev%sm2 => lev%sm2a - end select - -end subroutine amg_d_base_onelev_setsm + select case(ipos_) + case(amg_smooth_pre_, amg_smooth_both_) + if (allocated(lv%sm)) then + if (.not.same_type_as(lv%sm,val)) then + call lv%sm%free(info) + deallocate(lv%sm, stat=info) + end if + endif + if (.not.allocated(lv%sm)) then + allocate(lv%sm,mold=val) + end if + call lv%sm%default() + if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm + case(amg_smooth_post_) + if (allocated(lv%sm2a)) then + if (.not.same_type_as(lv%sm2a,val)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + endif + end if + if (.not.allocated(lv%sm2a)) then + allocate(lv%sm2a,mold=val) + end if + call lv%sm2a%default() + lv%sm2 => lv%sm2a + end select + + end subroutine amg_d_base_onelev_setsm + +end submodule amg_d_base_onelev_setsm_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_setsv.F90 b/amgprec/impl/level/amg_d_base_onelev_setsv.F90 index 9381a987..1f960969 100644 --- a/amgprec/impl/level/amg_d_base_onelev_setsv.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_setsv.F90 @@ -35,110 +35,111 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_d_base_onelev_setsv(lev,val,info,pos) - +submodule (amg_d_onelev_mod) amg_d_base_onelev_setsv_impl use psb_base_mod - use amg_d_prec_mod, amg_protect_name => amg_d_base_onelev_setsv - - implicit none - - ! Arguments - class(amg_d_onelev_type), target, intent(inout) :: lev - class(amg_d_base_solver_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsv' +contains + module subroutine amg_d_base_onelev_setsv(lv,val,info,pos) + implicit none - info = psb_success_ + ! Arguments + class(amg_d_onelev_type), target, intent(inout) :: lv + class(amg_d_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then - if (allocated(lev%sm)) then - if (allocated(lev%sm%sv)) then - if (.not.same_type_as(lev%sm%sv,val)) then - call lev%sm%sv%free(info) - if (info == 0) deallocate(lev%sm%sv,stat=info) + end if + + if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then + if (allocated(lv%sm)) then + if (allocated(lv%sm%sv)) then + if (.not.same_type_as(lv%sm%sv,val)) then + call lv%sm%sv%free(info) + if (info == 0) deallocate(lv%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%sm%sv)) then + allocate(lv%sm%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if + call lv%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + end if - - if (.not.allocated(lev%sm%sv)) then - allocate(lev%sm%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - end if - end if - ! - ! If POS was not specified and therefore we have amg_smooth_both_ - ! we need to update sm2a *only* if it was already allocated, - ! otherwise it is not needed (since we have just fixed %sm in the - ! pre section). - ! + ! + ! If POS was not specified and therefore we have amg_smooth_both_ + ! we need to update sm2a *only* if it was already allocated, + ! otherwise it is not needed (since we have just fixed %sm in the + ! pre section). + ! - if ((ipos_ == amg_smooth_post_).or. & - ((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then + if ((ipos_ == amg_smooth_post_).or. & + ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then - if (allocated(lev%sm2a)) then - if (allocated(lev%sm2a%sv)) then - if (.not.same_type_as(lev%sm2a%sv,val)) then - call lev%sm2a%sv%free(info) - if (info == 0) deallocate(lev%sm2a%sv,stat=info) + if (allocated(lv%sm2a)) then + if (allocated(lv%sm2a%sv)) then + if (.not.same_type_as(lv%sm2a%sv,val)) then + call lv%sm2a%sv%free(info) + if (info == 0) deallocate(lv%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lv%sm2a%sv)) then + allocate(lv%sm2a%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if - end if - if (.not.allocated(lev%sm2a%sv)) then - allocate(lev%sm2a%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm2a%sv%default() - - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - - end if - - end if - -end subroutine amg_d_base_onelev_setsv + call lv%sm2a%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + + end if + + end if + + end subroutine amg_d_base_onelev_setsv + +end submodule amg_d_base_onelev_setsv_impl diff --git a/amgprec/impl/level/amg_d_base_onelev_wrk_handle.f90 b/amgprec/impl/level/amg_d_base_onelev_wrk_handle.f90 new file mode 100644 index 00000000..da87e4e0 --- /dev/null +++ b/amgprec/impl/level/amg_d_base_onelev_wrk_handle.f90 @@ -0,0 +1,333 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +submodule (amg_d_onelev_mod) amg_d_base_onelev_wrk_handle_impl + use psb_base_mod + +contains + + module subroutine d_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + b%parms = lv%parms + b%szratio = lv%szratio + if (associated(lv%sm2,lv%sm2a)) then + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + + call move_alloc(lv%aggr,b%aggr) + if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) + if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) + if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) + b%base_a => lv%base_a + b%base_desc => lv%base_desc + + end subroutine d_base_onelev_move_alloc + + module subroutine d_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv, i + info = psb_success_ + nwv = lv%get_wrksz() + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) +!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() + if (info == 0) then + if (lv%remap_data%desc_ac_pre_remap%is_asb()) then + ! + ! Need to fix this, we need two different allocations + ! + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& + & desc2=lv%remap_data%desc_ac_pre_remap) + else + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end if + end if + + end subroutine d_base_onelev_allocate_wrk + + module subroutine d_base_onelev_free_wrk(lv,info) + implicit none + class(amg_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv,i + info = psb_success_ + + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if + end subroutine d_base_onelev_free_wrk + + module subroutine d_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) +!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& +!!$ & present(desc2),desc%is_valid() + + allocate(wk%wv(nwv),stat=info) + if (present(desc2).and.(desc%is_valid())) then +!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() + if (desc2%get_local_cols()>desc%get_local_cols()) then + call d_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else + call d_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + else if (present(desc2)) then + call d_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else if (desc%is_valid()) then + call d_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + + contains + end subroutine d_wrk_alloc + + module subroutine d_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_d_base_vect_type), intent(in), optional :: vmold + + integer(psb_ipk_) :: i + + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + do i=1,nwv + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + end subroutine d_inner_do_wrk_alloc + + + module subroutine d_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine d_wrk_free + + module subroutine d_wrk_clone(wk,wkout,info) + Implicit None + + ! Arguments + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + class(amg_dmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) + end do + return + + end subroutine d_wrk_clone + + module subroutine d_wrk_move_alloc(wk, b,info) + implicit none + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine d_wrk_move_alloc + + module subroutine d_wrk_cnv(wk,info,vmold) + Implicit None + + ! Arguments + class(amg_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + if (present(vmold)) then + call wk%vtx%cnv(vmold) + call wk%vty%cnv(vmold) + call wk%vx2l%cnv(vmold) + call wk%vy2l%cnv(vmold) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%cnv(vmold) + end do + end if + end if + end subroutine d_wrk_cnv + + module function d_wrk_sizeof(wk) result(val) + implicit none + class(amg_dmlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + integer :: i + val = 0 + val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%tx) + val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%ty) + val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%x2l) + val = val + (1_psb_epk_ * psb_sizeof_dp) * psb_size(wk%y2l) + val = val + wk%vtx%sizeof() + val = val + wk%vty%sizeof() + val = val + wk%vx2l%sizeof() + val = val + wk%vy2l%sizeof() + if (allocated(wk%wv)) then + do i=1, size(wk%wv) + val = val + wk%wv(i)%sizeof() + end do + end if + end function d_wrk_sizeof + + module subroutine d_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_d_remap_data_type), target, intent(inout) :: rmp + class(amg_d_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) + call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) + end subroutine d_remap_data_clone + + module subroutine d_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_d_remap_data_type), target, intent(inout) :: rmp + class(amg_d_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call move_alloc(rmp%isrc,remap_out%isrc) + call move_alloc(rmp%nrsrc,remap_out%nrsrc) + call move_alloc(rmp%naggr,remap_out%naggr) + end subroutine d_remap_move_alloc + +end submodule amg_d_base_onelev_wrk_handle_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_build.f90 b/amgprec/impl/level/amg_s_base_onelev_build.f90 index 7bcca484..67c154d1 100644 --- a/amgprec/impl/level/amg_s_base_onelev_build.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_build.f90 @@ -35,129 +35,132 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv) +submodule (amg_s_onelev_mod) amg_s_base_onelev_build_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_build - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - integer(psb_ipk_), intent(in), optional :: ilv - ! Local - integer(psb_ipk_) :: err,i,k, err_act - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: me, np - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + +contains + module subroutine amg_s_base_onelev_build(lv,info,amold,vmold,imold,ilv) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + integer(psb_ipk_), intent(in), optional :: ilv + ! Local + integer(psb_ipk_) :: err,i,k, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name, ch_err - name = 'amg_onelev_build' - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - if (.not.associated(lv%base_desc)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Unassociated base DESC') - goto 9999 - end if - info = psb_success_ - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - - ! - ! At top level(s) I may be using - ! a context with less processes - ! - if (me < 0) then -!!$ write(0,*) 'onelevbld: I am excluded from this one ' - else -!!$ write(0,*) me,' Going to build smoothers at this level ' - if (.not.allocated(lv%sm)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 + name = 'amg_onelev_build' + info=psb_success_ + err=0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 end if - if (.not.allocated(lv%sm%sv)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - lv%ac_nz_loc = lv%ac%get_nzeros() - lv%ac_nz_tot = lv%ac_nz_loc - select case(lv%parms%coarse_mat) - case(amg_distr_mat_) - call psb_sum(ctxt,lv%ac_nz_tot) - case(amg_repl_mat_) - ! Do nothing - case default - ! Should never get here - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Wrong lv%parms') - goto 9999 - end select - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',izero,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',izero,is_int_non_negative) - - call lv%sm%build(lv%base_a,lv%base_desc,info) - if (info == 0) then - if (allocated(lv%sm2a)) then - call lv%sm2a%build(lv%base_a,lv%base_desc,info) - lv%sm2 => lv%sm2a - else - lv%sm2 => lv%sm - end if - end if - if (info /=0 ) then + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + if (.not.associated(lv%base_desc)) then info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Smoother bld error') + & a_err='Unassociated base DESC') goto 9999 end if - - if (lv%sm%sv%is_global()) then - if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then - lv%parms%sweeps_pre = 1 - lv%parms%sweeps_post = 1 - if (me == 0) then - write(debug_unit,*) - if (present(ilv)) then - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" at level ',ilv - write(debug_unit,*) ' is configured as a global solver ' - else - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" is configured as a global solver ' + info = psb_success_ + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + ! + ! At top level(s) I may be using + ! a context with less processes + ! + if (me < 0) then +!!$ write(0,*) 'onelevbld: I am excluded from this one ' + else +!!$ write(0,*) me,' Going to build smoothers at this level ' + if (.not.allocated(lv%sm)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(lv%sm%sv)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + lv%ac_nz_loc = lv%ac%get_nzeros() + lv%ac_nz_tot = lv%ac_nz_loc + select case(lv%parms%coarse_mat) + case(amg_distr_mat_) + call psb_sum(ctxt,lv%ac_nz_tot) + case(amg_repl_mat_) + ! Do nothing + case default + ! Should never get here + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Wrong lv%parms') + goto 9999 + end select + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',izero,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',izero,is_int_non_negative) + + call lv%sm%build(lv%base_a,lv%base_desc,info) + if (info == 0) then + if (allocated(lv%sm2a)) then + call lv%sm2a%build(lv%base_a,lv%base_desc,info) + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if + end if + if (info /=0 ) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Smoother bld error') + goto 9999 + end if + + if (lv%sm%sv%is_global()) then + if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then + lv%parms%sweeps_pre = 1 + lv%parms%sweeps_post = 1 + if (me == 0) then + write(debug_unit,*) + if (present(ilv)) then + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" at level ',ilv + write(debug_unit,*) ' is configured as a global solver ' + else + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" is configured as a global solver ' + end if + write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if - write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if end if end if - end if - - if (any((/present(amold),present(vmold),present(imold)/))) & - & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) - call psb_erractionrestore(err_act) - return + if (any((/present(amold),present(vmold),present(imold)/))) & + & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_s_base_onelev_build + end subroutine amg_s_base_onelev_build +end submodule amg_s_base_onelev_build_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_check.f90 b/amgprec/impl/level/amg_s_base_onelev_check.f90 index 2ea5041e..2d8732a0 100644 --- a/amgprec/impl/level/amg_s_base_onelev_check.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_check.f90 @@ -35,59 +35,60 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_check(lv,info) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_check_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_check - - Implicit None - - ! Arguments - class(amg_s_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='s_base_onelev_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',ione,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',ione,is_int_non_negative) - - if (allocated(lv%sm)) then - call lv%sm%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (allocated(lv%sm2a)) then - call lv%sm2a%check(info) - else if (.not.inner_check(lv%sm2,lv%sm)) then - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return contains - function inner_check(smp,sm) result(res) - implicit none - logical :: res - class(amg_s_base_smoother_type), intent(in), pointer :: smp - class(amg_s_base_smoother_type), intent(in), target :: sm + module subroutine amg_s_base_onelev_check(lv,info) + Implicit None - res = associated(smp, sm) - end function inner_check - -end subroutine amg_s_base_onelev_check + ! Arguments + class(amg_s_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_base_onelev_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',ione,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',ione,is_int_non_negative) + + if (allocated(lv%sm)) then + call lv%sm%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (allocated(lv%sm2a)) then + call lv%sm2a%check(info) + else if (.not.inner_check(lv%sm2,lv%sm)) then + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + contains + function inner_check(smp,sm) result(res) + implicit none + logical :: res + class(amg_s_base_smoother_type), intent(in), pointer :: smp + class(amg_s_base_smoother_type), intent(in), target :: sm + + res = associated(smp, sm) + end function inner_check + + end subroutine amg_s_base_onelev_check +end submodule amg_s_base_onelev_check_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_cnv.f90 b/amgprec/impl/level/amg_s_base_onelev_cnv.f90 index 5b10ed6e..2201bda8 100644 --- a/amgprec/impl/level/amg_s_base_onelev_cnv.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_cnv.f90 @@ -35,33 +35,36 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_cnv_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_cnv - implicit none - - class(amg_s_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - - integer(psb_ipk_) :: i - - info = psb_success_ - if (any((/present(amold),present(vmold),present(imold)/))) then - if (allocated(lv%sm)) & - & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%sm2a)) & - & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%wrk)) & - & call lv%wrk%cnv(info,vmold=vmold) - if (info == psb_success_.and. lv%ac%is_asb()) & - & call lv%ac%cscnv(info,mold=amold) - if (info == psb_success_ .and. lv%desc_ac%is_ok() & - & .and. present(imold)) call lv%desc_ac%cnv(imold) - if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) - end if -end subroutine amg_s_base_onelev_cnv +contains + module subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold) + + implicit none + + class(amg_s_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + + integer(psb_ipk_) :: i + + info = psb_success_ + + if (any((/present(amold),present(vmold),present(imold)/))) then + if (allocated(lv%sm)) & + & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%sm2a)) & + & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%wrk)) & + & call lv%wrk%cnv(info,vmold=vmold) + if (info == psb_success_.and. lv%ac%is_asb()) & + & call lv%ac%cscnv(info,mold=amold) + if (info == psb_success_ .and. lv%desc_ac%is_ok() & + & .and. present(imold)) call lv%desc_ac%cnv(imold) + if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) + end if + end subroutine amg_s_base_onelev_cnv +end submodule amg_s_base_onelev_cnv_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 index c4d3d810..cf80a313 100644 --- a/amgprec/impl/level/amg_s_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_csetc.F90 @@ -35,285 +35,289 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_csetc_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_csetc - use amg_s_base_aggregator_mod - use amg_s_dec_aggregator_mod - use amg_s_symdec_aggregator_mod - use amg_s_parmatch_aggregator_mod - use amg_s_poly_smoother - use amg_s_jac_smoother - use amg_s_as_smoother - use amg_s_diag_solver - use amg_s_l1_diag_solver - use amg_s_jac_solver - use amg_s_ilu_solver - use amg_s_id_solver - use amg_s_gs_solver - use amg_s_ainv_solver - use amg_s_invk_solver - use amg_s_invt_solver + +contains + module subroutine amg_s_base_onelev_csetc(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_s_base_aggregator_mod + use amg_s_dec_aggregator_mod + use amg_s_symdec_aggregator_mod + use amg_s_parmatch_aggregator_mod + use amg_s_poly_smoother + use amg_s_jac_smoother + use amg_s_as_smoother + use amg_s_diag_solver + use amg_s_l1_diag_solver + use amg_s_jac_solver + use amg_s_ilu_solver + use amg_s_id_solver + use amg_s_gs_solver + use amg_s_ainv_solver + use amg_s_invk_solver + use amg_s_invt_solver #if defined(AMG_HAVE_SLU) - use amg_s_slu_solver + use amg_s_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_s_mumps_solver + use amg_s_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_s_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='s_base_onelev_csetc' - integer(psb_ipk_) :: ival - type(amg_s_base_smoother_type) :: amg_s_base_smoother_mold - type(amg_s_jac_smoother_type) :: amg_s_jac_smoother_mold - type(amg_s_l1_jac_smoother_type) :: amg_s_l1_jac_smoother_mold - type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold - type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold - type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold - type(amg_s_jac_solver_type) :: amg_s_jac_solver_mold - type(amg_s_l1_jac_solver_type) :: amg_s_l1_jac_solver_mold - type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold - type(amg_s_id_solver_type) :: amg_s_id_solver_mold - type(amg_s_gs_solver_type) :: amg_s_gs_solver_mold - type(amg_s_bwgs_solver_type) :: amg_s_bwgs_solver_mold - type(amg_s_ainv_solver_type) :: amg_s_ainv_solver_mold - type(amg_s_invk_solver_type) :: amg_s_invk_solver_mold - type(amg_s_invt_solver_type) :: amg_s_invt_solver_mold - type(amg_s_poly_smoother_type) :: amg_s_poly_smoother_mold + ! Arguments + class(amg_s_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='s_base_onelev_csetc' + integer(psb_ipk_) :: ival + type(amg_s_base_smoother_type) :: amg_s_base_smoother_mold + type(amg_s_jac_smoother_type) :: amg_s_jac_smoother_mold + type(amg_s_l1_jac_smoother_type) :: amg_s_l1_jac_smoother_mold + type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold + type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold + type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold + type(amg_s_jac_solver_type) :: amg_s_jac_solver_mold + type(amg_s_l1_jac_solver_type) :: amg_s_l1_jac_solver_mold + type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold + type(amg_s_id_solver_type) :: amg_s_id_solver_mold + type(amg_s_gs_solver_type) :: amg_s_gs_solver_mold + type(amg_s_bwgs_solver_type) :: amg_s_bwgs_solver_mold + type(amg_s_ainv_solver_type) :: amg_s_ainv_solver_mold + type(amg_s_invk_solver_type) :: amg_s_invk_solver_mold + type(amg_s_invt_solver_type) :: amg_s_invt_solver_mold + type(amg_s_poly_smoother_type) :: amg_s_poly_smoother_mold #if defined(AMG_HAVE_SLU) - type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold + type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold + type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold #endif - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - ival = lv%stringval(val) + ival = lv%stringval(val) - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(trim(what))) - case ('SMOOTHER_TYPE') - select case (psb_toupper(trim(val))) - case ('NOPREC','NONE') - call lv%set(amg_s_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_id_solver_mold,info,pos=pos) - - case ('JAC','JACOBI') - call lv%set(amg_s_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_diag_solver_mold,info,pos=pos) - - case ('L1-JACOBI') - call lv%set(amg_s_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) - - case ('BJAC') - call lv%set(amg_s_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - - case ('L1-BJAC') - call lv%set(amg_s_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - - case ('AS') - call lv%set(amg_s_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - - case ('POLY') - call lv%set(amg_s_poly_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) - case ('GS','FWGS') - call lv%set(amg_s_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('BWGS') - call lv%set(amg_s_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('FBGS') - call lv%set(amg_s_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') - call lv%set(amg_s_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post') - case ('L1-GS','L1-FWGS') - call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-BWGS') - call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-FBGS') - call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') - call lv%set(amg_s_l1_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(trim(what))) + case ('SMOOTHER_TYPE') + select case (psb_toupper(trim(val))) + case ('NOPREC','NONE') + call lv%set(amg_s_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (psb_toupper(trim(val))) - case ('NONE','NOPREC','FACT_NONE') - call lv%set(amg_s_id_solver_mold,info,pos=pos) + case ('JAC','JACOBI') + call lv%set(amg_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_diag_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') - call lv%set(amg_s_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') - call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) + case ('BJAC') + call lv%set(amg_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - case ('GS','FGS','FWGS') - call lv%set(amg_s_gs_solver_mold,info,pos=pos) + case ('L1-BJAC') + call lv%set(amg_s_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - case ('BGS','BWGS') - call lv%set(amg_s_bwgs_solver_mold,info,pos=pos) + case ('AS') + call lv%set(amg_s_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - case ('AINV') - call lv%set(amg_s_ainv_solver_mold,info,pos=pos) - case ('INVK') - call lv%set(amg_s_invk_solver_mold,info,pos=pos) - case ('INVT') - call lv%set(amg_s_invt_solver_mold,info,pos=pos) - case ('ILU','ILUT','MILU') - call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case ('POLY') + call lv%set(amg_s_poly_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) + case ('GS','FWGS') + call lv%set(amg_s_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('BWGS') + call lv%set(amg_s_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('FBGS') + call lv%set(amg_s_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') + call lv%set(amg_s_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post') + case ('L1-GS','L1-FWGS') + call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-BWGS') + call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-FBGS') + call lv%set(amg_s_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') + call lv%set(amg_s_l1_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (psb_toupper(trim(val))) + case ('NONE','NOPREC','FACT_NONE') + call lv%set(amg_s_id_solver_mold,info,pos=pos) + + case ('DIAG','JACOBI') + call lv%set(amg_s_diag_solver_mold,info,pos=pos) + + case ('L1-DIAG','L1-JACOBI') + call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) + + case ('GS','FGS','FWGS') + call lv%set(amg_s_gs_solver_mold,info,pos=pos) + + case ('BGS','BWGS') + call lv%set(amg_s_bwgs_solver_mold,info,pos=pos) + + case ('AINV') + call lv%set(amg_s_ainv_solver_mold,info,pos=pos) + case ('INVK') + call lv%set(amg_s_invk_solver_mold,info,pos=pos) + case ('INVT') + call lv%set(amg_s_invt_solver_mold,info,pos=pos) + case ('ILU','ILUT','MILU') + call lv%set(amg_s_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case ('SLU') - call lv%set(amg_s_slu_solver_mold,info,pos=pos) + case ('SLU') + call lv%set(amg_s_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case ('MUMPS') - call lv%set(amg_s_mumps_solver_mold,info,pos=pos) + case ('MUMPS') + call lv%set(amg_s_mumps_solver_mold,info,pos=pos) #endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select + case default + ! + ! Do nothing and hope for the best :) + ! + end select - case ('ML_CYCLE') - lv%parms%ml_cycle = amg_stringval(val) + case ('ML_CYCLE') + lv%parms%ml_cycle = amg_stringval(val) - case ('PAR_AGGR_ALG') - ival = amg_stringval(val) - lv%parms%par_aggr_alg = ival - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='aggregator deallocation?') + case ('PAR_AGGR_ALG') + ival = amg_stringval(val) + lv%parms%par_aggr_alg = ival + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='aggregator deallocation?') + goto 9999 + return + end if + end if + + select case(val) + case('DEC','DECOUPLED') + allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info) + case('SYMDEC') + allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info) + case('COUP','COUPLED') + allocate(amg_s_parmatch_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') goto 9999 - return - end if - end if + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = amg_stringval(val) + + case ('AGGR_TYPE') + lv%parms%aggr_type = amg_stringval(val) + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = amg_stringval(val) + + case ('COARSE_MAT') + lv%parms%coarse_mat = amg_stringval(val) + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= amg_stringval(val) + + case ('AGGR_EIG') + lv%parms%aggr_eig = amg_stringval(val) + + case ('AGGR_FILTER') + lv%parms%aggr_filter = amg_stringval(val) + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = amg_stringval(val) + + case default + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - select case(val) - case('DEC','DECOUPLED') - allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info) - case('SYMDEC') - allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info) - case('COUP','COUPLED') - allocate(amg_s_parmatch_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') - goto 9999 end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = amg_stringval(val) - - case ('AGGR_TYPE') - lv%parms%aggr_type = amg_stringval(val) - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = amg_stringval(val) - - case ('COARSE_MAT') - lv%parms%coarse_mat = amg_stringval(val) - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= amg_stringval(val) - - case ('AGGR_EIG') - lv%parms%aggr_eig = amg_stringval(val) - - case ('AGGR_FILTER') - lv%parms%aggr_filter = amg_stringval(val) - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = amg_stringval(val) - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_s_base_onelev_csetc + end subroutine amg_s_base_onelev_csetc +end submodule amg_s_base_onelev_csetc_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_cseti.F90 b/amgprec/impl/level/amg_s_base_onelev_cseti.F90 index 5c60971d..386519a3 100644 --- a/amgprec/impl/level/amg_s_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_cseti.F90 @@ -35,235 +35,239 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_cseti_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_cseti - use amg_s_base_aggregator_mod - use amg_s_dec_aggregator_mod - use amg_s_symdec_aggregator_mod - use amg_s_parmatch_aggregator_mod - use amg_s_jac_smoother - use amg_s_as_smoother - use amg_s_diag_solver - use amg_s_l1_diag_solver - use amg_s_ilu_solver - use amg_s_id_solver - use amg_s_gs_solver + +contains + module subroutine amg_s_base_onelev_cseti(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_s_base_aggregator_mod + use amg_s_dec_aggregator_mod + use amg_s_symdec_aggregator_mod + use amg_s_parmatch_aggregator_mod + use amg_s_jac_smoother + use amg_s_as_smoother + use amg_s_diag_solver + use amg_s_l1_diag_solver + use amg_s_ilu_solver + use amg_s_id_solver + use amg_s_gs_solver #if defined(AMG_HAVE_SLU) - use amg_s_slu_solver + use amg_s_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_s_mumps_solver + use amg_s_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_s_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='s_base_onelev_cseti' - type(amg_s_base_smoother_type) :: amg_s_base_smoother_mold - type(amg_s_jac_smoother_type) :: amg_s_jac_smoother_mold - type(amg_s_l1_jac_smoother_type) :: amg_s_l1_jac_smoother_mold - type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold - type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold - type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold - type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold - type(amg_s_id_solver_type) :: amg_s_id_solver_mold - type(amg_s_gs_solver_type) :: amg_s_gs_solver_mold - type(amg_s_bwgs_solver_type) :: amg_s_bwgs_solver_mold + ! Arguments + class(amg_s_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='s_base_onelev_cseti' + type(amg_s_base_smoother_type) :: amg_s_base_smoother_mold + type(amg_s_jac_smoother_type) :: amg_s_jac_smoother_mold + type(amg_s_l1_jac_smoother_type) :: amg_s_l1_jac_smoother_mold + type(amg_s_as_smoother_type) :: amg_s_as_smoother_mold + type(amg_s_diag_solver_type) :: amg_s_diag_solver_mold + type(amg_s_l1_diag_solver_type) :: amg_s_l1_diag_solver_mold + type(amg_s_ilu_solver_type) :: amg_s_ilu_solver_mold + type(amg_s_id_solver_type) :: amg_s_id_solver_mold + type(amg_s_gs_solver_type) :: amg_s_gs_solver_mold + type(amg_s_bwgs_solver_type) :: amg_s_bwgs_solver_mold #if defined(AMG_HAVE_SLU) - type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold + type(amg_s_slu_solver_type) :: amg_s_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold + type(amg_s_mumps_solver_type) :: amg_s_mumps_solver_mold #endif - call psb_erractionsave(err_act) - info = psb_success_ + call psb_erractionsave(err_act) + info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(what)) - case ('SMOOTHER_TYPE') - select case (val) - case (amg_noprec_) - call lv%set(amg_s_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_id_solver_mold,info,pos=pos) - - case (amg_jac_) - call lv%set(amg_s_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_diag_solver_mold,info,pos=pos) - - case (amg_l1_jac_) - call lv%set(amg_s_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) - - case (amg_bjac_) - call lv%set(amg_s_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - - case (amg_l1_bjac_) - call lv%set(amg_s_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - - case (amg_as_) - call lv%set(amg_s_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - - case (amg_fbgs_) - call lv%set(amg_s_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') - call lv%set(amg_s_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (amg_noprec_) + call lv%set(amg_s_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (val) - case (amg_f_none_) - call lv%set(amg_s_id_solver_mold,info,pos=pos) + case (amg_jac_) + call lv%set(amg_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_diag_solver_mold,info,pos=pos) - case (amg_diag_scale_) - call lv%set(amg_s_diag_solver_mold,info,pos=pos) + case (amg_l1_jac_) + call lv%set(amg_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) - case (amg_l1_diag_scale_) - call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) + case (amg_bjac_) + call lv%set(amg_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - case (amg_gs_) - call lv%set(amg_s_gs_solver_mold,info,pos=pos) + case (amg_l1_bjac_) + call lv%set(amg_s_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - case (amg_bwgs_) - call lv%set(amg_s_bwgs_solver_mold,info,pos=pos) + case (amg_as_) + call lv%set(amg_s_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) - call lv%set(amg_s_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case (amg_fbgs_) + call lv%set(amg_s_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_s_gs_solver_mold,info,pos='pre') + call lv%set(amg_s_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_s_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (val) + case (amg_f_none_) + call lv%set(amg_s_id_solver_mold,info,pos=pos) + + case (amg_diag_scale_) + call lv%set(amg_s_diag_solver_mold,info,pos=pos) + + case (amg_l1_diag_scale_) + call lv%set(amg_s_l1_diag_solver_mold,info,pos=pos) + + case (amg_gs_) + call lv%set(amg_s_gs_solver_mold,info,pos=pos) + + case (amg_bwgs_) + call lv%set(amg_s_bwgs_solver_mold,info,pos=pos) + + case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) + call lv%set(amg_s_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case (amg_slu_) - call lv%set(amg_s_slu_solver_mold,info,pos=pos) + case (amg_slu_) + call lv%set(amg_s_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case (amg_mumps_) - call lv%set(amg_s_mumps_solver_mold,info,pos=pos) + case (amg_mumps_) + call lv%set(amg_s_mumps_solver_mold,info,pos=pos) #endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_pre = val + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_post = val + + case ('ML_CYCLE') + lv%parms%ml_cycle = val + + case ('PAR_AGGR_ALG') + lv%parms%par_aggr_alg = val + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + return + end if + end if + + select case(val) + case(amg_dec_aggr_) + allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info) + case(amg_sym_dec_aggr_) + allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_TYPE') + lv%parms%aggr_type = val + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + case default - ! - ! Do nothing and hope for the best :) - ! + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + end select - - - case ('SMOOTHER_SWEEPS') - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_pre = val - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_post = val - - case ('ML_CYCLE') - lv%parms%ml_cycle = val - - case ('PAR_AGGR_ALG') - lv%parms%par_aggr_alg = val - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - return - end if - end if - - select case(val) - case(amg_dec_aggr_) - allocate(amg_s_dec_aggregator_type :: lv%aggr, stat=info) - case(amg_sym_dec_aggr_) - allocate(amg_s_symdec_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = val - - case ('AGGR_TYPE') - lv%parms%aggr_type = val - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = val - - case ('COARSE_MAT') - lv%parms%coarse_mat = val - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= val - - case ('AGGR_EIG') - lv%parms%aggr_eig = val - - case ('AGGR_FILTER') - lv%parms%aggr_filter = val - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = val - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_s_base_onelev_cseti + end subroutine amg_s_base_onelev_cseti +end submodule amg_s_base_onelev_cseti_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_csetr.f90 b/amgprec/impl/level/amg_s_base_onelev_csetr.f90 index a865e523..52922bc7 100644 --- a/amgprec/impl/level/amg_s_base_onelev_csetr.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_csetr.f90 @@ -35,71 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_csetr_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_csetr + +contains + module subroutine amg_s_base_onelev_csetr(lv,what,val,info,pos,idx) - Implicit None + Implicit None - ! Arguments - class(amg_s_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='s_base_onelev_csetr' + ! Arguments + class(amg_s_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='s_base_onelev_csetr' - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - select case (psb_toupper(what)) + select case (psb_toupper(what)) - case ('AGGR_OMEGA_VAL') - lv%parms%aggr_omega_val= val + case ('AGGR_OMEGA_VAL') + lv%parms%aggr_omega_val= val - case ('AGGR_THRESH') - lv%parms%aggr_thresh = val + case ('AGGR_THRESH') + lv%parms%aggr_thresh = val - case default - - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + case default + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) + + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - end select + end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_s_base_onelev_csetr + end subroutine amg_s_base_onelev_csetr +end submodule amg_s_base_onelev_csetr_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_descr.f90 b/amgprec/impl/level/amg_s_base_onelev_descr.f90 index 98d103ff..12894378 100644 --- a/amgprec/impl/level/amg_s_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_descr.f90 @@ -42,114 +42,116 @@ ! 0: normal ! >1: increased details ! -subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_descr_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_descr - Implicit None - ! Arguments - class(amg_s_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - integer(psb_ipk_), intent(in), optional :: verbosity - character(len=*), intent(in), optional :: prefix - - - ! Local variables - integer(psb_ipk_) :: err_act - character(len=20), parameter :: name='amg_s_base_onelev_descr' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse - character(1024) :: prefix_ - type(psb_ctxt_type) :: pctxt - integer(psb_ipk_) :: pme, pnp - - - call psb_erractionsave(err_act) - - - coarse = (il==nl) - - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - - pctxt = lv%desc_ac%get_ctxt() - call psb_info(pctxt,pme,pnp) - write(iout_,*) trim(prefix_) - write(iout_,*) 'At level :',il,' we have ',pnp,' processes' - write(iout_,*) trim(prefix_) - if (il == ilmin) then - call lv%parms%mlcycledsc(iout_,info) - end if - if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then - if (allocated(lv%aggr)) then - call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) - else - write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 +contains + module subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) + Implicit None + ! Arguments + class(amg_s_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_s_base_onelev_descr' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp + + + call psb_erractionsave(err_act) + + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 + end if + if (verbosity_ < 0) goto 9998 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) write(iout_,*) trim(prefix_) - end if - - if (il > 1) then - - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' + write(iout_,*) trim(prefix_) + if (il == ilmin) then + call lv%parms%mlcycledsc(iout_,info) end if - - call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) - - if (nl > 1) then - if (allocated(lv%linmap%naggr)) then - write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & - & lv%linmap%nagtot - write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot - if (verbosity_>0) then - write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & - & lv%linmap%naggr(:) - else - write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& - & ' Local matrix sizes: min:', & - & lv%linmap%nagmin,' max:', lv%linmap%nagmax - write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& - & ' avg:', & - & lv%linmap%nagavg - end if - write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& - & ' Aggregation ratio: ', & - & lv%szratio + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then + if (allocated(lv%aggr)) then + call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) + else + write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 end if + write(iout_,*) trim(prefix_) end if - if (coarse.and.allocated(lv%sm)) & - & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) - end if + if (il > 1) then + + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + + call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) + + if (nl > 1) then + if (allocated(lv%linmap%naggr)) then + write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & + & lv%linmap%nagtot + write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot + if (verbosity_>0) then + write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & + & lv%linmap%naggr(:) + else + write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& + & ' Local matrix sizes: min:', & + & lv%linmap%nagmin,' max:', lv%linmap%nagmax + write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& + & ' avg:', & + & lv%linmap%nagavg + end if + write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& + & ' Aggregation ratio: ', & + & lv%szratio + end if + end if + + if (coarse.and.allocated(lv%sm)) & + & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) + end if 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_s_base_onelev_descr + end subroutine amg_s_base_onelev_descr +end submodule amg_s_base_onelev_descr_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_dump.f90 b/amgprec/impl/level/amg_s_base_onelev_dump.f90 index ad7cb26a..d8588507 100644 --- a/amgprec/impl/level/amg_s_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_dump.f90 @@ -35,135 +35,137 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& - & smoother,solver,tprol,global_num) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_dump_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_dump - implicit none - class(amg_s_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: level - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num - ! Local variables - integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np - character(len=80) :: prefix_, frmt - character(len=1024) :: fname - logical :: ac_, rp_, tprol_, global_num_ - integer(psb_lpk_), allocatable :: ivr(:), ivc(:) - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_lev_s" - end if - - if (associated(lv%base_desc)) then - ctxt = lv%base_desc%get_context() - call psb_info(ctxt,iam,np) - else - iam = -1 - np = -1 - end if - if (present(ac)) then - ac_ = ac - else - ac_ = .false. - end if - if (present(rp)) then - rp_ = rp - else - rp_ = .false. - end if - if (present(tprol)) then - tprol_ = tprol - else - tprol_ = .false. - end if - if (present(global_num)) then - global_num_ = global_num - else - global_num_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - - if (np > 0) then - ni = floor(log10(1.0*np)) + 1 - write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' - write(fname(lname+1:lname+ni+2),frmt) '_p',iam - lname = lname + ni + 2 - end if - - if (global_num_) then - if (level == 1) then - if (ac_) then - ivr = lv%base_desc%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head,iv=ivr) - end if - else if (level >= 2) then - if (ac_) then - ivr = lv%desc_ac%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head,iv=ivr) - end if - if (rp_) then - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) - end if - if (tprol_) then - ! Tentative prolongator is stored with column indices already - ! in global numbering, so only IVR is needed. - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head,ivr=ivr) - end if - end if - else - if (level == 1) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head) - end if - else if (level >= 2) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head) - end if - if (rp_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head) - end if - if (tprol_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head) - end if - end if - end if - if (level >= 1) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) +contains + module subroutine amg_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& + & smoother,solver,tprol,global_num) + implicit none + class(amg_s_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num + ! Local variables + integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_, frmt + character(len=1024) :: fname + logical :: ac_, rp_, tprol_, global_num_ + integer(psb_lpk_), allocatable :: ivr(:), ivc(:) + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_lev_s" end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + + if (associated(lv%base_desc)) then + ctxt = lv%base_desc%get_context() + call psb_info(ctxt,iam,np) + else + iam = -1 + np = -1 end if - end if - -end subroutine amg_s_base_onelev_dump + if (present(ac)) then + ac_ = ac + else + ac_ = .false. + end if + if (present(rp)) then + rp_ = rp + else + rp_ = .false. + end if + if (present(tprol)) then + tprol_ = tprol + else + tprol_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + + if (np > 0) then + ni = floor(log10(1.0*np)) + 1 + write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' + write(fname(lname+1:lname+ni+2),frmt) '_p',iam + lname = lname + ni + 2 + end if + + if (global_num_) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then + if (ac_) then + ivr = lv%desc_ac%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head,iv=ivr) + end if + if (rp_) then + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) + end if + if (tprol_) then + ! Tentative prolongator is stored with column indices already + ! in global numbering, so only IVR is needed. + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head,ivr=ivr) + end if + end if + else + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head) + end if + if (rp_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head) + end if + if (tprol_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head) + end if + end if + end if + + if (level >= 1) then + if (allocated(lv%sm)) then + call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) + end if + if (allocated(lv%sm2a)) then + call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + end if + end if + + end subroutine amg_s_base_onelev_dump +end submodule amg_s_base_onelev_dump_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_free.f90 b/amgprec/impl/level/amg_s_base_onelev_free.f90 index 01bd291d..e4384cf9 100644 --- a/amgprec/impl/level/amg_s_base_onelev_free.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_free.f90 @@ -35,41 +35,43 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_free(lv,info) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_free_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_free - implicit none + +contains + module subroutine amg_s_base_onelev_free(lv,info) + implicit none - class(amg_s_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_s_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) - if (allocated(lv%wrk)) & - & call lv%wrk%free(info) + if (allocated(lv%wrk)) & + & call lv%wrk%free(info) - call lv%ac%free() - if (lv%desc_ac%is_ok()) & - & call lv%desc_ac%free(info) - call lv%linmap%free(info) + call lv%ac%free() + if (lv%desc_ac%is_ok()) & + & call lv%desc_ac%free(info) + call lv%linmap%free(info) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_a) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_desc) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_a) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_desc) - call lv%nullify() + call lv%nullify() -end subroutine amg_s_base_onelev_free + end subroutine amg_s_base_onelev_free +end submodule amg_s_base_onelev_free_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_free_smoothers.f90 b/amgprec/impl/level/amg_s_base_onelev_free_smoothers.f90 index 8fa4ae3f..e05f693c 100644 --- a/amgprec/impl/level/amg_s_base_onelev_free_smoothers.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_free_smoothers.f90 @@ -35,26 +35,28 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_free_smoothers(lv,info) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_dree_smoothers_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_free_smoothers - implicit none + +contains + module subroutine amg_s_base_onelev_free_smoothers(lv,info) + implicit none - class(amg_s_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_s_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) -end subroutine amg_s_base_onelev_free_smoothers + end subroutine amg_s_base_onelev_free_smoothers +end submodule amg_s_base_onelev_dree_smoothers_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_map_prol.F90 b/amgprec/impl/level/amg_s_base_onelev_map_prol.F90 index 0ceaf150..7e74562a 100644 --- a/amgprec/impl/level/amg_s_base_onelev_map_prol.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_map_prol.F90 @@ -35,112 +35,113 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_prol_v - - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv - real(psb_spk_), intent(in) :: alpha, beta - type(psb_s_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), optional :: work(:) - type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_s_vect_type), pointer :: vtx_ +submodule (amg_s_onelev_mod) amg_s_base_onelev_map_prol_impl + use psb_base_mod + +contains + module subroutine amg_s_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + real(psb_spk_), intent(in) :: alpha, beta + type(psb_s_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), optional :: work(:) + type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty + + type(psb_s_vect_type), pointer :: vtx_ !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vtx)) then - vtx_ => vtx - else - vtx_ => lv%wrk%wv(1) - end if - -!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! -!!$ write(0,*) 'Remap handling ' - block - type(psb_ctxt_type) :: ctxt, nctxt - integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp - integer(psb_mpk_) :: me, np, rme, rnp - real(psb_spk_), allocatable :: rsnd(:), rrcv(:) - type(psb_s_vect_type) :: tv + if (present(vtx)) then + vtx_ => vtx + else + vtx_ => lv%wrk%wv(1) + end if - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) +!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! +!!$ write(0,*) 'Remap handling ' + block + type(psb_ctxt_type) :: ctxt, nctxt + integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp + integer(psb_mpk_) :: me, np, rme, rnp +real(psb_spk_), allocatable :: rsnd(:), rrcv(:) + type(psb_s_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal() - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + nctxt = lv%desc_ac%get_ctxt() + call psb_info(nctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal() - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal() - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) - rrcv = vect_v%get_vect() + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) + rrcv = vect_v%get_vect() !!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl - call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - end if - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + end if + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) !!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal() - - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info !!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal() !!$ call psb_realloc(nrc,rsnd,info) !!$ call psb_rcv(ctxt,rsnd(1:nrl),idest) !!$ call tv%set_vect(rsnd) - call psb_rcv(ctxt,tv%v%v(1:nrl),idest) - call tv%set_host() - call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end associate + call psb_rcv(ctxt,tv%v%v(1:nrl),idest) + call tv%set_host() + call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end associate !!$ write(0,*) me, ' Prolongator with remap done ' !!$ flush(0) !!$ call psb_barrier(ctxt) - end block - else - ! Default transfer - call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end if - -end subroutine amg_s_base_onelev_map_prol_v + end block + else + ! Default transfer + call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end if -subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_prol_a - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv - real(psb_spk_), intent(in) :: alpha, beta - real(psb_spk_), intent(inout) :: u(:) - real(psb_spk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), optional :: work(:) + end subroutine amg_s_base_onelev_map_prol_v - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap P handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_V2U(alpha,v,beta,u,info,& - & work=work) - end if - -end subroutine amg_s_base_onelev_map_prol_a + module subroutine amg_s_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(inout) :: u(:) + real(psb_spk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), optional :: work(:) + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap P handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_V2U(alpha,v,beta,u,info,& + & work=work) + end if + + end subroutine amg_s_base_onelev_map_prol_a +end submodule amg_s_base_onelev_map_prol_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 index ce8cc74a..9e362c4b 100644 --- a/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 @@ -36,114 +36,115 @@ ! ! -subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& - & work,vtx,vty) +submodule (amg_s_onelev_mod) amg_s_base_onelev_map_rstr_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_rstr_v - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv - real(psb_spk_), intent(in) :: alpha, beta - type(psb_s_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), optional :: work(:) - type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_s_vect_type), pointer :: vty_ - integer(psb_mpk_) :: me, np + +contains + module subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + real(psb_spk_), intent(in) :: alpha, beta + type(psb_s_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), optional :: work(:) + type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty + type(psb_s_vect_type), pointer :: vty_ + integer(psb_mpk_) :: me, np !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vty)) then - vty_ => vty - else - vty_ => lv%wrk%wv(1) - end if - - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! + if (present(vty)) then + vty_ => vty + else + vty_ => lv%wrk%wv(1) + end if + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! !!$ write(0,*) 'Remap handling not implemented yet ' - block - type(psb_ctxt_type) :: ctxt, rctxt - integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp - integer(psb_mpk_) :: rme, rnp - real(psb_spk_), allocatable :: rsnd(:), rrcv(:) - type(psb_s_vect_type) :: tv - - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) - rctxt = lv%desc_ac%get_ctxt() - call psb_info(rctxt,rme,rnp) + block + type(psb_ctxt_type) :: ctxt, rctxt + integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp + integer(psb_mpk_) :: rme, rnp +real(psb_spk_), allocatable :: rsnd(:), rrcv(:) + type(psb_s_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context map rstr',rme,rnp,me,np - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest !!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:) - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),& !!$ & psb_errstatus_fatal() !!$ flush(0) - call psb_barrier(ctxt) - call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& - & work=work,vtx=vtx,vty=vty_) - call tv%sync() - !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + call psb_barrier(ctxt) + call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& + & work=work,vtx=vtx,vty=vty_) + call tv%sync() + !rsnd = tv%get_vect() + !call psb_snd(ctxt,rsnd(1:nrl),idest) !!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal() - call psb_snd(ctxt,tv%v%v(1:nrl),idest) - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) + call psb_snd(ctxt,tv%v%v(1:nrl),idest) + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) !!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal() - call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - call vect_v%set_vect(rrcv) - end if - end associate + call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + call vect_v%set_vect(rrcv) + end if + end associate !!$ write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal() - end block - - else - ! Default transfer - block - type(psb_ctxt_type) :: ctxt, rctxt - ctxt = lv%linmap%p_desc_U%get_ctxt() - call psb_info(ctxt,me,np) + end block + + else + ! Default transfer + block + type(psb_ctxt_type) :: ctxt, rctxt + ctxt = lv%linmap%p_desc_U%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) me,' map_rstr calling U2V: ',me,np - call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& - & work=work,vtx=vtx,vty=vty_) - end block - end if + call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& + & work=work,vtx=vtx,vty=vty_) + end block + end if !!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal() -end subroutine amg_s_base_onelev_map_rstr_v + end subroutine amg_s_base_onelev_map_rstr_v -subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_map_rstr_a - implicit none - class(amg_s_onelev_type), target, intent(inout) :: lv - real(psb_spk_), intent(in) :: alpha, beta - real(psb_spk_), intent(inout) :: u(:) - real(psb_spk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), optional :: work(:) + module subroutine amg_s_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(inout) :: u(:) + real(psb_spk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), optional :: work(:) - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap R handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_U2V(alpha,u,beta,v,info,& - & work=work) - end if - -end subroutine amg_s_base_onelev_map_rstr_a + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap R handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_U2V(alpha,u,beta,v,info,& + & work=work) + end if + + end subroutine amg_s_base_onelev_map_rstr_a +end submodule amg_s_base_onelev_map_rstr_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_mat_asb.f90 b/amgprec/impl/level/amg_s_base_onelev_mat_asb.f90 index b613651b..b60ee546 100644 --- a/amgprec/impl/level/amg_s_base_onelev_mat_asb.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_mat_asb.f90 @@ -83,109 +83,111 @@ ! info - integer, output. ! Error code. ! -subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_mat_asb_impl use psb_base_mod use amg_base_prec_type - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_mat_asb - - implicit none - - ! Arguments - class(amg_s_onelev_type), intent(inout), target :: lv - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(inout) :: desc_a - integer(psb_lpk_), intent(inout) :: nlaggr(:) - integer(psb_lpk_), intent(inout) :: ilaggr(:) - type(psb_lsspmat_type), intent(inout) :: t_prol - integer(psb_ipk_), intent(out) :: info +contains + module subroutine amg_s_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - ! Local variables - character(len=24) :: name - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - type(psb_sspmat_type) :: ac, op_restr, op_prol - integer(psb_ipk_) :: nzl, inl - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 - logical, parameter :: do_timings=.false. + implicit none - name='amg_s_onelev_mat_asb' - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - info = psb_success_ - ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) - if ((do_timings).and.(idx_matbld==-1)) & - & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") - if ((do_timings).and.(idx_matasb==-1)) & - & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") - if ((do_timings).and.(idx_mapbld==-1)) & - & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - - call amg_check_def(lv%parms%aggr_prol,'Smoother',& - & amg_smooth_prol_,is_legal_ml_aggr_prol) - call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& - & amg_distr_mat_,is_legal_ml_coarse_mat) - call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& - & amg_no_filter_mat_,is_legal_aggr_filter) - call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& - & amg_eig_est_,is_legal_ml_aggr_omega_alg) - call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& - & amg_max_norm_,is_legal_ml_aggr_eig) - call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega) + ! Arguments + class(amg_s_onelev_type), intent(inout), target :: lv + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(inout) :: nlaggr(:) + integer(psb_lpk_), intent(inout) :: ilaggr(:) + type(psb_lsspmat_type), intent(inout) :: t_prol + integer(psb_ipk_), intent(out) :: info - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by lv%iprcparm(amg_aggr_prol_) - ! - if (do_timings) call psb_tic(idx_matbld) - call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& - & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) - if (do_timings) call psb_toc(idx_matbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') - goto 9999 - end if + ! Local variables + character(len=24) :: name + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + type(psb_sspmat_type) :: ac, op_restr, op_prol + integer(psb_ipk_) :: nzl, inl + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 + logical, parameter :: do_timings=.false. - ! - ! Now build its descriptor and convert global indices for - ! ac, op_restr and op_prol - ! - if (do_timings) call psb_tic(idx_matasb) - if (info == psb_success_) & - & call lv%aggr%mat_asb(lv%parms,a,desc_a,& - & lv%ac,lv%desc_ac,op_prol,op_restr,info) - if (do_timings) call psb_toc(idx_matasb) - if (do_timings) call psb_tic(idx_mapbld) - if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - - if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& - & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) - if (do_timings) call psb_toc(idx_mapbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') - goto 9999 - end if - ! - ! Fix the base_a and base_desc pointers for handling of residuals. - ! This is correct because this routine is only called at levels >=2. - ! - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac + name='amg_s_onelev_mat_asb' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if ((do_timings).and.(idx_matbld==-1)) & + & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") + if ((do_timings).and.(idx_matasb==-1)) & + & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") + if ((do_timings).and.(idx_mapbld==-1)) & + & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - call psb_erractionrestore(err_act) - return + call amg_check_def(lv%parms%aggr_prol,'Smoother',& + & amg_smooth_prol_,is_legal_ml_aggr_prol) + call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& + & amg_distr_mat_,is_legal_ml_coarse_mat) + call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& + & amg_no_filter_mat_,is_legal_aggr_filter) + call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& + & amg_eig_est_,is_legal_ml_aggr_omega_alg) + call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& + & amg_max_norm_,is_legal_ml_aggr_eig) + call amg_check_def(lv%parms%aggr_omega_val,'Omega',szero,is_legal_s_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by lv%iprcparm(amg_aggr_prol_) + ! + if (do_timings) call psb_tic(idx_matbld) + call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& + & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) + if (do_timings) call psb_toc(idx_matbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') + goto 9999 + end if + + ! + ! Now build its descriptor and convert global indices for + ! ac, op_restr and op_prol + ! + if (do_timings) call psb_tic(idx_matasb) + if (info == psb_success_) & + & call lv%aggr%mat_asb(lv%parms,a,desc_a,& + & lv%ac,lv%desc_ac,op_prol,op_restr,info) + if (do_timings) call psb_toc(idx_matasb) + if (do_timings) call psb_tic(idx_mapbld) + if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + + if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& + & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) + if (do_timings) call psb_toc(idx_mapbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') + goto 9999 + end if + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_s_base_onelev_mat_asb + end subroutine amg_s_base_onelev_mat_asb +end submodule amg_s_base_onelev_mat_asb_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 index 8221ac5f..8c4ba186 100644 --- a/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_memory_use.f90 @@ -42,109 +42,112 @@ ! 0: normal ! >1: increased details ! -subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_memory_use_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_memory_use - Implicit None - ! Arguments - class(amg_s_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - character(len=*), intent(in), optional :: prefix - integer(psb_ipk_), intent(in), optional :: verbosity - logical, intent(in), optional :: global - - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: err_act ,me, np - character(len=20), parameter :: name='amg_s_base_onelev_memory_use' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse, global_ - character(1024) :: prefix_ - integer(psb_epk_), allocatable :: sz(:) - - - call psb_erractionsave(err_act) - - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - coarse = (il==nl) +contains + module subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity,prefix,global) + Implicit None + ! Arguments + class(amg_s_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + character(len=*), intent(in), optional :: prefix + integer(psb_ipk_), intent(in), optional :: verbosity + logical, intent(in), optional :: global - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(global)) then - global_ = global - else - global_ = .true. - end if + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act ,me, np + character(len=20), parameter :: name='amg_s_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse, global_ + character(1024) :: prefix_ + integer(psb_epk_), allocatable :: sz(:) - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + call psb_erractionsave(err_act) - if (global_) then - allocate(sz(6)) - sz(:) = 0 - sz(1) = lv%base_a%sizeof() - sz(2) = lv%base_desc%sizeof() - if (il >1) sz(3) = lv%linmap%sizeof() - if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() - if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() - if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() - call psb_sum(ctxt,sz) - if (me == 0) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', sz(1) - write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if - - else - if ((me == 0).or.(verbosity_>0)) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() - write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 end if - endif + if (verbosity_ < 0) goto 9998 + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + + if (global_) then + allocate(sz(6)) + sz(:) = 0 + sz(1) = lv%base_a%sizeof() + sz(2) = lv%base_desc%sizeof() + if (il >1) sz(3) = lv%linmap%sizeof() + if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() + if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() + if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() + call psb_sum(ctxt,sz) + if (me == 0) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', sz(1) + write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + end if + + else + if ((me == 0).or.(verbosity_>0)) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() + write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + end if + endif 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_s_base_onelev_memory_use + end subroutine amg_s_base_onelev_memory_use +end submodule amg_s_base_onelev_memory_use_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_setag.f90 b/amgprec/impl/level/amg_s_base_onelev_setag.f90 index 5ccc3002..9192b178 100644 --- a/amgprec/impl/level/amg_s_base_onelev_setag.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_setag.f90 @@ -35,48 +35,50 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_setag(lv,val,info,pos) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_setag_impl use psb_base_mod - use amg_s_onelev_mod, amg_protect_name => amg_s_base_onelev_setag - - implicit none - - ! Arguments - class(amg_s_onelev_type), target, intent(inout) :: lv - class(amg_s_base_aggregator_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setag' +contains + module subroutine amg_s_base_onelev_setag(lv,val,info,pos) - info = psb_success_ + implicit none - ! Ignore pos for aggregator - - if (allocated(lv%aggr)) then - if (.not.same_type_as(lv%aggr,val)) then - call lv%aggr%free(info) - deallocate(lv%aggr,stat=info) + ! Arguments + class(amg_s_onelev_type), target, intent(inout) :: lv + class(amg_s_base_aggregator_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setag' + + info = psb_success_ + + ! Ignore pos for aggregator + + if (allocated(lv%aggr)) then + if (.not.same_type_as(lv%aggr,val)) then + call lv%aggr%free(info) + deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%aggr)) then + allocate(lv%aggr,mold=val,stat=info) if (info /= 0) then info = 3111 return end if + lv%parms%par_aggr_alg = amg_ext_aggr_ + lv%parms%aggr_type = amg_noalg_ + call lv%aggr%default() end if - end if - - if (.not.allocated(lv%aggr)) then - allocate(lv%aggr,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - lv%parms%par_aggr_alg = amg_ext_aggr_ - lv%parms%aggr_type = amg_noalg_ - call lv%aggr%default() - end if - -end subroutine amg_s_base_onelev_setag + end subroutine amg_s_base_onelev_setag + +end submodule amg_s_base_onelev_setag_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_setsm.F90 b/amgprec/impl/level/amg_s_base_onelev_setsm.F90 index aa38d5ef..c13508b8 100644 --- a/amgprec/impl/level/amg_s_base_onelev_setsm.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_setsm.F90 @@ -35,72 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_setsm(lev,val,info,pos) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_setsm_impl use psb_base_mod - use amg_s_prec_mod, amg_protect_name => amg_s_base_onelev_setsm - - implicit none - - ! Arguments - class(amg_s_onelev_type), target, intent(inout) :: lev - class(amg_s_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsm' - - info = psb_success_ +contains + module subroutine amg_s_base_onelev_setsm(lv,val,info,pos) + implicit none - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Arguments + class(amg_s_onelev_type), target, intent(inout) :: lv + class(amg_s_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if (ipos_ == amg_smooth_both_) then - if (allocated(lev%sm2a)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - lev%sm2 => null() end if - end if - - select case(ipos_) - case(amg_smooth_pre_, amg_smooth_both_) - if (allocated(lev%sm)) then - if (.not.same_type_as(lev%sm,val)) then - call lev%sm%free(info) - deallocate(lev%sm, stat=info) + + if (ipos_ == amg_smooth_both_) then + if (allocated(lv%sm2a)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + lv%sm2 => null() end if - endif - if (.not.allocated(lev%sm)) then - allocate(lev%sm,mold=val) end if - call lev%sm%default() - if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm - case(amg_smooth_post_) - if (allocated(lev%sm2a)) then - if (.not.same_type_as(lev%sm2a,val)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - endif - end if - if (.not.allocated(lev%sm2a)) then - allocate(lev%sm2a,mold=val) - end if - call lev%sm2a%default() - lev%sm2 => lev%sm2a - end select - -end subroutine amg_s_base_onelev_setsm + select case(ipos_) + case(amg_smooth_pre_, amg_smooth_both_) + if (allocated(lv%sm)) then + if (.not.same_type_as(lv%sm,val)) then + call lv%sm%free(info) + deallocate(lv%sm, stat=info) + end if + endif + if (.not.allocated(lv%sm)) then + allocate(lv%sm,mold=val) + end if + call lv%sm%default() + if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm + case(amg_smooth_post_) + if (allocated(lv%sm2a)) then + if (.not.same_type_as(lv%sm2a,val)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + endif + end if + if (.not.allocated(lv%sm2a)) then + allocate(lv%sm2a,mold=val) + end if + call lv%sm2a%default() + lv%sm2 => lv%sm2a + end select + + end subroutine amg_s_base_onelev_setsm + +end submodule amg_s_base_onelev_setsm_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_setsv.F90 b/amgprec/impl/level/amg_s_base_onelev_setsv.F90 index 82dbdad6..b243d985 100644 --- a/amgprec/impl/level/amg_s_base_onelev_setsv.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_setsv.F90 @@ -35,110 +35,111 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_s_base_onelev_setsv(lev,val,info,pos) - +submodule (amg_s_onelev_mod) amg_s_base_onelev_setsv_impl use psb_base_mod - use amg_s_prec_mod, amg_protect_name => amg_s_base_onelev_setsv - - implicit none - - ! Arguments - class(amg_s_onelev_type), target, intent(inout) :: lev - class(amg_s_base_solver_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsv' +contains + module subroutine amg_s_base_onelev_setsv(lv,val,info,pos) + implicit none - info = psb_success_ + ! Arguments + class(amg_s_onelev_type), target, intent(inout) :: lv + class(amg_s_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then - if (allocated(lev%sm)) then - if (allocated(lev%sm%sv)) then - if (.not.same_type_as(lev%sm%sv,val)) then - call lev%sm%sv%free(info) - if (info == 0) deallocate(lev%sm%sv,stat=info) + end if + + if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then + if (allocated(lv%sm)) then + if (allocated(lv%sm%sv)) then + if (.not.same_type_as(lv%sm%sv,val)) then + call lv%sm%sv%free(info) + if (info == 0) deallocate(lv%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%sm%sv)) then + allocate(lv%sm%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if + call lv%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + end if - - if (.not.allocated(lev%sm%sv)) then - allocate(lev%sm%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - end if - end if - ! - ! If POS was not specified and therefore we have amg_smooth_both_ - ! we need to update sm2a *only* if it was already allocated, - ! otherwise it is not needed (since we have just fixed %sm in the - ! pre section). - ! + ! + ! If POS was not specified and therefore we have amg_smooth_both_ + ! we need to update sm2a *only* if it was already allocated, + ! otherwise it is not needed (since we have just fixed %sm in the + ! pre section). + ! - if ((ipos_ == amg_smooth_post_).or. & - ((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then + if ((ipos_ == amg_smooth_post_).or. & + ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then - if (allocated(lev%sm2a)) then - if (allocated(lev%sm2a%sv)) then - if (.not.same_type_as(lev%sm2a%sv,val)) then - call lev%sm2a%sv%free(info) - if (info == 0) deallocate(lev%sm2a%sv,stat=info) + if (allocated(lv%sm2a)) then + if (allocated(lv%sm2a%sv)) then + if (.not.same_type_as(lv%sm2a%sv,val)) then + call lv%sm2a%sv%free(info) + if (info == 0) deallocate(lv%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lv%sm2a%sv)) then + allocate(lv%sm2a%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if - end if - if (.not.allocated(lev%sm2a%sv)) then - allocate(lev%sm2a%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm2a%sv%default() - - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - - end if - - end if - -end subroutine amg_s_base_onelev_setsv + call lv%sm2a%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + + end if + + end if + + end subroutine amg_s_base_onelev_setsv + +end submodule amg_s_base_onelev_setsv_impl diff --git a/amgprec/impl/level/amg_s_base_onelev_wrk_handle.f90 b/amgprec/impl/level/amg_s_base_onelev_wrk_handle.f90 new file mode 100644 index 00000000..429f4896 --- /dev/null +++ b/amgprec/impl/level/amg_s_base_onelev_wrk_handle.f90 @@ -0,0 +1,333 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +submodule (amg_s_onelev_mod) amg_s_base_onelev_wrk_handle_impl + use psb_base_mod + +contains + + module subroutine s_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + b%parms = lv%parms + b%szratio = lv%szratio + if (associated(lv%sm2,lv%sm2a)) then + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + + call move_alloc(lv%aggr,b%aggr) + if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) + if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) + if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) + b%base_a => lv%base_a + b%base_desc => lv%base_desc + + end subroutine s_base_onelev_move_alloc + + module subroutine s_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv, i + info = psb_success_ + nwv = lv%get_wrksz() + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) +!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() + if (info == 0) then + if (lv%remap_data%desc_ac_pre_remap%is_asb()) then + ! + ! Need to fix this, we need two different allocations + ! + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& + & desc2=lv%remap_data%desc_ac_pre_remap) + else + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end if + end if + + end subroutine s_base_onelev_allocate_wrk + + module subroutine s_base_onelev_free_wrk(lv,info) + implicit none + class(amg_s_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv,i + info = psb_success_ + + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if + end subroutine s_base_onelev_free_wrk + + module subroutine s_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) +!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& +!!$ & present(desc2),desc%is_valid() + + allocate(wk%wv(nwv),stat=info) + if (present(desc2).and.(desc%is_valid())) then +!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() + if (desc2%get_local_cols()>desc%get_local_cols()) then + call s_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else + call s_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + else if (present(desc2)) then + call s_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else if (desc%is_valid()) then + call s_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + + contains + end subroutine s_wrk_alloc + + module subroutine s_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_s_base_vect_type), intent(in), optional :: vmold + + integer(psb_ipk_) :: i + + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + do i=1,nwv + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + end subroutine s_inner_do_wrk_alloc + + + module subroutine s_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine s_wrk_free + + module subroutine s_wrk_clone(wk,wkout,info) + Implicit None + + ! Arguments + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + class(amg_smlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) + end do + return + + end subroutine s_wrk_clone + + module subroutine s_wrk_move_alloc(wk, b,info) + implicit none + class(amg_smlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine s_wrk_move_alloc + + module subroutine s_wrk_cnv(wk,info,vmold) + Implicit None + + ! Arguments + class(amg_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + if (present(vmold)) then + call wk%vtx%cnv(vmold) + call wk%vty%cnv(vmold) + call wk%vx2l%cnv(vmold) + call wk%vy2l%cnv(vmold) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%cnv(vmold) + end do + end if + end if + end subroutine s_wrk_cnv + + module function s_wrk_sizeof(wk) result(val) + implicit none + class(amg_smlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + integer :: i + val = 0 + val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%tx) + val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%ty) + val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%x2l) + val = val + (1_psb_epk_ * psb_sizeof_sp) * psb_size(wk%y2l) + val = val + wk%vtx%sizeof() + val = val + wk%vty%sizeof() + val = val + wk%vx2l%sizeof() + val = val + wk%vy2l%sizeof() + if (allocated(wk%wv)) then + do i=1, size(wk%wv) + val = val + wk%wv(i)%sizeof() + end do + end if + end function s_wrk_sizeof + + module subroutine s_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_s_remap_data_type), target, intent(inout) :: rmp + class(amg_s_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) + call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) + end subroutine s_remap_data_clone + + module subroutine s_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_s_remap_data_type), target, intent(inout) :: rmp + class(amg_s_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call move_alloc(rmp%isrc,remap_out%isrc) + call move_alloc(rmp%nrsrc,remap_out%nrsrc) + call move_alloc(rmp%naggr,remap_out%naggr) + end subroutine s_remap_move_alloc + +end submodule amg_s_base_onelev_wrk_handle_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_build.f90 b/amgprec/impl/level/amg_z_base_onelev_build.f90 index b404e8f0..57d60b01 100644 --- a/amgprec/impl/level/amg_z_base_onelev_build.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_build.f90 @@ -35,129 +35,132 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv) +submodule (amg_z_onelev_mod) amg_z_base_onelev_build_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_build - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - integer(psb_ipk_), intent(in), optional :: ilv - ! Local - integer(psb_ipk_) :: err,i,k, err_act - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: me, np - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + +contains + module subroutine amg_z_base_onelev_build(lv,info,amold,vmold,imold,ilv) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + integer(psb_ipk_), intent(in), optional :: ilv + ! Local + integer(psb_ipk_) :: err,i,k, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name, ch_err - name = 'amg_onelev_build' - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - if (.not.associated(lv%base_desc)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Unassociated base DESC') - goto 9999 - end if - info = psb_success_ - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - - ! - ! At top level(s) I may be using - ! a context with less processes - ! - if (me < 0) then -!!$ write(0,*) 'onelevbld: I am excluded from this one ' - else -!!$ write(0,*) me,' Going to build smoothers at this level ' - if (.not.allocated(lv%sm)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 + name = 'amg_onelev_build' + info=psb_success_ + err=0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 end if - if (.not.allocated(lv%sm%sv)) then - !! Error: should have called amg_dprecinit - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - lv%ac_nz_loc = lv%ac%get_nzeros() - lv%ac_nz_tot = lv%ac_nz_loc - select case(lv%parms%coarse_mat) - case(amg_distr_mat_) - call psb_sum(ctxt,lv%ac_nz_tot) - case(amg_repl_mat_) - ! Do nothing - case default - ! Should never get here - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Wrong lv%parms') - goto 9999 - end select - - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling mlprcbld at level ',i - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',izero,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',izero,is_int_non_negative) - - call lv%sm%build(lv%base_a,lv%base_desc,info) - if (info == 0) then - if (allocated(lv%sm2a)) then - call lv%sm2a%build(lv%base_a,lv%base_desc,info) - lv%sm2 => lv%sm2a - else - lv%sm2 => lv%sm - end if - end if - if (info /=0 ) then + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + if (.not.associated(lv%base_desc)) then info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Smoother bld error') + & a_err='Unassociated base DESC') goto 9999 end if - - if (lv%sm%sv%is_global()) then - if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then - lv%parms%sweeps_pre = 1 - lv%parms%sweeps_post = 1 - if (me == 0) then - write(debug_unit,*) - if (present(ilv)) then - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" at level ',ilv - write(debug_unit,*) ' is configured as a global solver ' - else - write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& - & '" is configured as a global solver ' + info = psb_success_ + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + ! + ! At top level(s) I may be using + ! a context with less processes + ! + if (me < 0) then +!!$ write(0,*) 'onelevbld: I am excluded from this one ' + else +!!$ write(0,*) me,' Going to build smoothers at this level ' + if (.not.allocated(lv%sm)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + if (.not.allocated(lv%sm%sv)) then + !! Error: should have called amg_dprecinit + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + lv%ac_nz_loc = lv%ac%get_nzeros() + lv%ac_nz_tot = lv%ac_nz_loc + select case(lv%parms%coarse_mat) + case(amg_distr_mat_) + call psb_sum(ctxt,lv%ac_nz_tot) + case(amg_repl_mat_) + ! Do nothing + case default + ! Should never get here + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Wrong lv%parms') + goto 9999 + end select + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Calling mlprcbld at level ',i + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',izero,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',izero,is_int_non_negative) + + call lv%sm%build(lv%base_a,lv%base_desc,info) + if (info == 0) then + if (allocated(lv%sm2a)) then + call lv%sm2a%build(lv%base_a,lv%base_desc,info) + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if + end if + if (info /=0 ) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Smoother bld error') + goto 9999 + end if + + if (lv%sm%sv%is_global()) then + if ((lv%parms%sweeps_pre>1).or.(lv%parms%sweeps_post>1)) then + lv%parms%sweeps_pre = 1 + lv%parms%sweeps_post = 1 + if (me == 0) then + write(debug_unit,*) + if (present(ilv)) then + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" at level ',ilv + write(debug_unit,*) ' is configured as a global solver ' + else + write(debug_unit,*) 'Warning: the solver "',trim(lv%sm%sv%get_fmt()),& + & '" is configured as a global solver ' + end if + write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if - write(debug_unit,*) ' Pre and post sweeps at this level reset to 1' end if end if end if - end if - - if (any((/present(amold),present(vmold),present(imold)/))) & - & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) - call psb_erractionrestore(err_act) - return + if (any((/present(amold),present(vmold),present(imold)/))) & + & call lv%cnv(info,amold=amold,vmold=vmold,imold=imold) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_z_base_onelev_build + end subroutine amg_z_base_onelev_build +end submodule amg_z_base_onelev_build_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_check.f90 b/amgprec/impl/level/amg_z_base_onelev_check.f90 index 106c5d3d..9a84a750 100644 --- a/amgprec/impl/level/amg_z_base_onelev_check.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_check.f90 @@ -35,59 +35,60 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_check(lv,info) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_check_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_check - - Implicit None - - ! Arguments - class(amg_z_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_base_onelev_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call amg_check_def(lv%parms%sweeps_pre,& - & 'Jacobi sweeps',ione,is_int_non_negative) - call amg_check_def(lv%parms%sweeps_post,& - & 'Jacobi sweeps',ione,is_int_non_negative) - - if (allocated(lv%sm)) then - call lv%sm%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (allocated(lv%sm2a)) then - call lv%sm2a%check(info) - else if (.not.inner_check(lv%sm2,lv%sm)) then - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return contains - function inner_check(smp,sm) result(res) - implicit none - logical :: res - class(amg_z_base_smoother_type), intent(in), pointer :: smp - class(amg_z_base_smoother_type), intent(in), target :: sm + module subroutine amg_z_base_onelev_check(lv,info) + Implicit None - res = associated(smp, sm) - end function inner_check - -end subroutine amg_z_base_onelev_check + ! Arguments + class(amg_z_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_base_onelev_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call amg_check_def(lv%parms%sweeps_pre,& + & 'Jacobi sweeps',ione,is_int_non_negative) + call amg_check_def(lv%parms%sweeps_post,& + & 'Jacobi sweeps',ione,is_int_non_negative) + + if (allocated(lv%sm)) then + call lv%sm%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (allocated(lv%sm2a)) then + call lv%sm2a%check(info) + else if (.not.inner_check(lv%sm2,lv%sm)) then + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + contains + function inner_check(smp,sm) result(res) + implicit none + logical :: res + class(amg_z_base_smoother_type), intent(in), pointer :: smp + class(amg_z_base_smoother_type), intent(in), target :: sm + + res = associated(smp, sm) + end function inner_check + + end subroutine amg_z_base_onelev_check +end submodule amg_z_base_onelev_check_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_cnv.f90 b/amgprec/impl/level/amg_z_base_onelev_cnv.f90 index 83d28669..a4883bfe 100644 --- a/amgprec/impl/level/amg_z_base_onelev_cnv.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_cnv.f90 @@ -35,33 +35,36 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_cnv_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_cnv - implicit none - - class(amg_z_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - class(psb_i_base_vect_type), intent(in), optional :: imold - - integer(psb_ipk_) :: i - - info = psb_success_ - if (any((/present(amold),present(vmold),present(imold)/))) then - if (allocated(lv%sm)) & - & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%sm2a)) & - & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) - if (info == psb_success_ .and. allocated(lv%wrk)) & - & call lv%wrk%cnv(info,vmold=vmold) - if (info == psb_success_.and. lv%ac%is_asb()) & - & call lv%ac%cscnv(info,mold=amold) - if (info == psb_success_ .and. lv%desc_ac%is_ok() & - & .and. present(imold)) call lv%desc_ac%cnv(imold) - if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) - end if -end subroutine amg_z_base_onelev_cnv +contains + module subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold) + + implicit none + + class(amg_z_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + + integer(psb_ipk_) :: i + + info = psb_success_ + + if (any((/present(amold),present(vmold),present(imold)/))) then + if (allocated(lv%sm)) & + & call lv%sm%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%sm2a)) & + & call lv%sm2a%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == psb_success_ .and. allocated(lv%wrk)) & + & call lv%wrk%cnv(info,vmold=vmold) + if (info == psb_success_.and. lv%ac%is_asb()) & + & call lv%ac%cscnv(info,mold=amold) + if (info == psb_success_ .and. lv%desc_ac%is_ok() & + & .and. present(imold)) call lv%desc_ac%cnv(imold) + if (info == psb_success_) call lv%linmap%cnv(info,mold=amold,imold=imold) + end if + end subroutine amg_z_base_onelev_cnv +end submodule amg_z_base_onelev_cnv_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_csetc.F90 b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 index 582442b6..cd8ba815 100644 --- a/amgprec/impl/level/amg_z_base_onelev_csetc.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_csetc.F90 @@ -35,297 +35,301 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_csetc_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_csetc - use amg_z_base_aggregator_mod - use amg_z_dec_aggregator_mod - use amg_z_symdec_aggregator_mod - use amg_z_jac_smoother - use amg_z_as_smoother - use amg_z_diag_solver - use amg_z_l1_diag_solver - use amg_z_jac_solver - use amg_z_ilu_solver - use amg_z_id_solver - use amg_z_gs_solver - use amg_z_ainv_solver - use amg_z_invk_solver - use amg_z_invt_solver + +contains + module subroutine amg_z_base_onelev_csetc(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_z_base_aggregator_mod + use amg_z_dec_aggregator_mod + use amg_z_symdec_aggregator_mod + use amg_z_jac_smoother + use amg_z_as_smoother + use amg_z_diag_solver + use amg_z_l1_diag_solver + use amg_z_jac_solver + use amg_z_ilu_solver + use amg_z_id_solver + use amg_z_gs_solver + use amg_z_ainv_solver + use amg_z_invk_solver + use amg_z_invt_solver #if defined(AMG_HAVE_UMF) - use amg_z_umf_solver + use amg_z_umf_solver #endif #if defined(AMG_HAVE_SLUDIST) - use amg_z_sludist_solver + use amg_z_sludist_solver #endif #if defined(AMG_HAVE_SLU) - use amg_z_slu_solver + use amg_z_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_z_mumps_solver + use amg_z_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_z_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='z_base_onelev_csetc' - integer(psb_ipk_) :: ival - type(amg_z_base_smoother_type) :: amg_z_base_smoother_mold - type(amg_z_jac_smoother_type) :: amg_z_jac_smoother_mold - type(amg_z_l1_jac_smoother_type) :: amg_z_l1_jac_smoother_mold - type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold - type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold - type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold - type(amg_z_jac_solver_type) :: amg_z_jac_solver_mold - type(amg_z_l1_jac_solver_type) :: amg_z_l1_jac_solver_mold - type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold - type(amg_z_id_solver_type) :: amg_z_id_solver_mold - type(amg_z_gs_solver_type) :: amg_z_gs_solver_mold - type(amg_z_bwgs_solver_type) :: amg_z_bwgs_solver_mold - type(amg_z_ainv_solver_type) :: amg_z_ainv_solver_mold - type(amg_z_invk_solver_type) :: amg_z_invk_solver_mold - type(amg_z_invt_solver_type) :: amg_z_invt_solver_mold + ! Arguments + class(amg_z_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + character(len=*), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='z_base_onelev_csetc' + integer(psb_ipk_) :: ival + type(amg_z_base_smoother_type) :: amg_z_base_smoother_mold + type(amg_z_jac_smoother_type) :: amg_z_jac_smoother_mold + type(amg_z_l1_jac_smoother_type) :: amg_z_l1_jac_smoother_mold + type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold + type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold + type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold + type(amg_z_jac_solver_type) :: amg_z_jac_solver_mold + type(amg_z_l1_jac_solver_type) :: amg_z_l1_jac_solver_mold + type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold + type(amg_z_id_solver_type) :: amg_z_id_solver_mold + type(amg_z_gs_solver_type) :: amg_z_gs_solver_mold + type(amg_z_bwgs_solver_type) :: amg_z_bwgs_solver_mold + type(amg_z_ainv_solver_type) :: amg_z_ainv_solver_mold + type(amg_z_invk_solver_type) :: amg_z_invk_solver_mold + type(amg_z_invt_solver_type) :: amg_z_invt_solver_mold #if defined(AMG_HAVE_UMF) - type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold + type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold #endif #if defined(AMG_HAVE_SLUDIST) - type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold + type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold #endif #if defined(AMG_HAVE_SLU) - type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold + type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold + type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold #endif - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - ival = lv%stringval(val) + ival = lv%stringval(val) - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(trim(what))) - case ('SMOOTHER_TYPE') - select case (psb_toupper(trim(val))) - case ('NOPREC','NONE') - call lv%set(amg_z_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_id_solver_mold,info,pos=pos) - - case ('JAC','JACOBI') - call lv%set(amg_z_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_diag_solver_mold,info,pos=pos) - - case ('L1-JACOBI') - call lv%set(amg_z_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) - - case ('BJAC') - call lv%set(amg_z_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - - case ('L1-BJAC') - call lv%set(amg_z_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - - case ('AS') - call lv%set(amg_z_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - - case ('GS','FWGS') - call lv%set(amg_z_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('BWGS') - call lv%set(amg_z_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('FBGS') - call lv%set(amg_z_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') - call lv%set(amg_z_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post') - case ('L1-GS','L1-FWGS') - call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-BWGS') - call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='pre') - if (allocated(lv%sm2a)) deallocate(lv%sm2a) - case ('L1-FBGS') - call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') - call lv%set(amg_z_l1_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(trim(what))) + case ('SMOOTHER_TYPE') + select case (psb_toupper(trim(val))) + case ('NOPREC','NONE') + call lv%set(amg_z_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (psb_toupper(trim(val))) - case ('NONE','NOPREC','FACT_NONE') - call lv%set(amg_z_id_solver_mold,info,pos=pos) + case ('JAC','JACOBI') + call lv%set(amg_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_diag_solver_mold,info,pos=pos) - case ('DIAG','JACOBI') - call lv%set(amg_z_diag_solver_mold,info,pos=pos) + case ('L1-JACOBI') + call lv%set(amg_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) - case ('L1-DIAG','L1-JACOBI') - call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) + case ('BJAC') + call lv%set(amg_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - case ('GS','FGS','FWGS') - call lv%set(amg_z_gs_solver_mold,info,pos=pos) + case ('L1-BJAC') + call lv%set(amg_z_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - case ('BGS','BWGS') - call lv%set(amg_z_bwgs_solver_mold,info,pos=pos) + case ('AS') + call lv%set(amg_z_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - case ('AINV') - call lv%set(amg_z_ainv_solver_mold,info,pos=pos) - case ('INVK') - call lv%set(amg_z_invk_solver_mold,info,pos=pos) - case ('INVT') - call lv%set(amg_z_invt_solver_mold,info,pos=pos) - case ('ILU','ILUT','MILU') - call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case ('GS','FWGS') + call lv%set(amg_z_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('BWGS') + call lv%set(amg_z_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('FBGS') + call lv%set(amg_z_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') + call lv%set(amg_z_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post') + case ('L1-GS','L1-FWGS') + call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-BWGS') + call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='pre') + if (allocated(lv%sm2a)) deallocate(lv%sm2a) + case ('L1-FBGS') + call lv%set(amg_z_l1_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') + call lv%set(amg_z_l1_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (psb_toupper(trim(val))) + case ('NONE','NOPREC','FACT_NONE') + call lv%set(amg_z_id_solver_mold,info,pos=pos) + + case ('DIAG','JACOBI') + call lv%set(amg_z_diag_solver_mold,info,pos=pos) + + case ('L1-DIAG','L1-JACOBI') + call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) + + case ('GS','FGS','FWGS') + call lv%set(amg_z_gs_solver_mold,info,pos=pos) + + case ('BGS','BWGS') + call lv%set(amg_z_bwgs_solver_mold,info,pos=pos) + + case ('AINV') + call lv%set(amg_z_ainv_solver_mold,info,pos=pos) + case ('INVK') + call lv%set(amg_z_invk_solver_mold,info,pos=pos) + case ('INVT') + call lv%set(amg_z_invt_solver_mold,info,pos=pos) + case ('ILU','ILUT','MILU') + call lv%set(amg_z_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case ('SLU') - call lv%set(amg_z_slu_solver_mold,info,pos=pos) + case ('SLU') + call lv%set(amg_z_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case ('MUMPS') - call lv%set(amg_z_mumps_solver_mold,info,pos=pos) + case ('MUMPS') + call lv%set(amg_z_mumps_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_SLUDIST - case ('SLUDIST') - call lv%set(amg_z_sludist_solver_mold,info,pos=pos) + case ('SLUDIST') + call lv%set(amg_z_sludist_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_UMF - case ('UMF') - call lv%set(amg_z_umf_solver_mold,info,pos=pos) + case ('UMF') + call lv%set(amg_z_umf_solver_mold,info,pos=pos) #endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select + case default + ! + ! Do nothing and hope for the best :) + ! + end select - case ('ML_CYCLE') - lv%parms%ml_cycle = amg_stringval(val) + case ('ML_CYCLE') + lv%parms%ml_cycle = amg_stringval(val) - case ('PAR_AGGR_ALG') - ival = amg_stringval(val) - lv%parms%par_aggr_alg = ival - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='aggregator deallocation?') + case ('PAR_AGGR_ALG') + ival = amg_stringval(val) + lv%parms%par_aggr_alg = ival + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='aggregator deallocation?') + goto 9999 + return + end if + end if + + select case(val) + case('DEC','DECOUPLED') + allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info) + case('SYMDEC') + allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') goto 9999 - return - end if - end if + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = amg_stringval(val) + + case ('AGGR_TYPE') + lv%parms%aggr_type = amg_stringval(val) + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = amg_stringval(val) + + case ('COARSE_MAT') + lv%parms%coarse_mat = amg_stringval(val) + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= amg_stringval(val) + + case ('AGGR_EIG') + lv%parms%aggr_eig = amg_stringval(val) + + case ('AGGR_FILTER') + lv%parms%aggr_filter = amg_stringval(val) + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = amg_stringval(val) + + case default + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - select case(val) - case('DEC','DECOUPLED') - allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info) - case('SYMDEC') - allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Unsupported PAR_AGGR_ALG') - goto 9999 end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = amg_stringval(val) - - case ('AGGR_TYPE') - lv%parms%aggr_type = amg_stringval(val) - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = amg_stringval(val) - - case ('COARSE_MAT') - lv%parms%coarse_mat = amg_stringval(val) - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= amg_stringval(val) - - case ('AGGR_EIG') - lv%parms%aggr_eig = amg_stringval(val) - - case ('AGGR_FILTER') - lv%parms%aggr_filter = amg_stringval(val) - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = amg_stringval(val) - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_z_base_onelev_csetc + end subroutine amg_z_base_onelev_csetc +end submodule amg_z_base_onelev_csetc_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_cseti.F90 b/amgprec/impl/level/amg_z_base_onelev_cseti.F90 index dcff1076..22eeabb8 100644 --- a/amgprec/impl/level/amg_z_base_onelev_cseti.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_cseti.F90 @@ -35,254 +35,258 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_cseti_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_cseti - use amg_z_base_aggregator_mod - use amg_z_dec_aggregator_mod - use amg_z_symdec_aggregator_mod - use amg_z_jac_smoother - use amg_z_as_smoother - use amg_z_diag_solver - use amg_z_l1_diag_solver - use amg_z_ilu_solver - use amg_z_id_solver - use amg_z_gs_solver + +contains + module subroutine amg_z_base_onelev_cseti(lv,what,val,info,pos,idx) + + use psb_base_mod + use amg_z_base_aggregator_mod + use amg_z_dec_aggregator_mod + use amg_z_symdec_aggregator_mod + use amg_z_jac_smoother + use amg_z_as_smoother + use amg_z_diag_solver + use amg_z_l1_diag_solver + use amg_z_ilu_solver + use amg_z_id_solver + use amg_z_gs_solver #if defined(AMG_HAVE_UMF) - use amg_z_umf_solver + use amg_z_umf_solver #endif #if defined(AMG_HAVE_SLUDIST) - use amg_z_sludist_solver + use amg_z_sludist_solver #endif #if defined(AMG_HAVE_SLU) - use amg_z_slu_solver + use amg_z_slu_solver #endif #if defined(AMG_HAVE_MUMPS) - use amg_z_mumps_solver + use amg_z_mumps_solver #endif - Implicit None + Implicit None - ! Arguments - class(amg_z_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='z_base_onelev_cseti' - type(amg_z_base_smoother_type) :: amg_z_base_smoother_mold - type(amg_z_jac_smoother_type) :: amg_z_jac_smoother_mold - type(amg_z_l1_jac_smoother_type) :: amg_z_l1_jac_smoother_mold - type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold - type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold - type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold - type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold - type(amg_z_id_solver_type) :: amg_z_id_solver_mold - type(amg_z_gs_solver_type) :: amg_z_gs_solver_mold - type(amg_z_bwgs_solver_type) :: amg_z_bwgs_solver_mold + ! Arguments + class(amg_z_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='z_base_onelev_cseti' + type(amg_z_base_smoother_type) :: amg_z_base_smoother_mold + type(amg_z_jac_smoother_type) :: amg_z_jac_smoother_mold + type(amg_z_l1_jac_smoother_type) :: amg_z_l1_jac_smoother_mold + type(amg_z_as_smoother_type) :: amg_z_as_smoother_mold + type(amg_z_diag_solver_type) :: amg_z_diag_solver_mold + type(amg_z_l1_diag_solver_type) :: amg_z_l1_diag_solver_mold + type(amg_z_ilu_solver_type) :: amg_z_ilu_solver_mold + type(amg_z_id_solver_type) :: amg_z_id_solver_mold + type(amg_z_gs_solver_type) :: amg_z_gs_solver_mold + type(amg_z_bwgs_solver_type) :: amg_z_bwgs_solver_mold #if defined(AMG_HAVE_UMF) - type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold + type(amg_z_umf_solver_type) :: amg_z_umf_solver_mold #endif #if defined(AMG_HAVE_SLUDIST) - type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold + type(amg_z_sludist_solver_type) :: amg_z_sludist_solver_mold #endif #if defined(AMG_HAVE_SLU) - type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold + type(amg_z_slu_solver_type) :: amg_z_slu_solver_mold #endif #if defined(AMG_HAVE_MUMPS) - type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold + type(amg_z_mumps_solver_type) :: amg_z_mumps_solver_mold #endif - call psb_erractionsave(err_act) - info = psb_success_ + call psb_erractionsave(err_act) + info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - select case (psb_toupper(what)) - case ('SMOOTHER_TYPE') - select case (val) - case (amg_noprec_) - call lv%set(amg_z_base_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_id_solver_mold,info,pos=pos) - - case (amg_jac_) - call lv%set(amg_z_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_diag_solver_mold,info,pos=pos) - - case (amg_l1_jac_) - call lv%set(amg_z_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) - - case (amg_bjac_) - call lv%set(amg_z_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - - case (amg_l1_bjac_) - call lv%set(amg_z_l1_jac_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - - case (amg_as_) - call lv%set(amg_z_as_smoother_mold,info,pos=pos) - if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - - case (amg_fbgs_) - call lv%set(amg_z_jac_smoother_mold,info,pos='pre') - if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') - call lv%set(amg_z_jac_smoother_mold,info,pos='post') - if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post') - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) call lv%sm%default() - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm2a)) call lv%sm2a%default() end if + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (amg_noprec_) + call lv%set(amg_z_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_id_solver_mold,info,pos=pos) - case('SUB_SOLVE') - select case (val) - case (amg_f_none_) - call lv%set(amg_z_id_solver_mold,info,pos=pos) + case (amg_jac_) + call lv%set(amg_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_diag_solver_mold,info,pos=pos) - case (amg_diag_scale_) - call lv%set(amg_z_diag_solver_mold,info,pos=pos) + case (amg_l1_jac_) + call lv%set(amg_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) - case (amg_l1_diag_scale_) - call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) + case (amg_bjac_) + call lv%set(amg_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - case (amg_gs_) - call lv%set(amg_z_gs_solver_mold,info,pos=pos) + case (amg_l1_bjac_) + call lv%set(amg_z_l1_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - case (amg_bwgs_) - call lv%set(amg_z_bwgs_solver_mold,info,pos=pos) + case (amg_as_) + call lv%set(amg_z_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) - call lv%set(amg_z_ilu_solver_mold,info,pos=pos) - if (info == 0) then - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - call lv%sm%sv%set('SUB_SOLVE',val,info) - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) - end if + case (amg_fbgs_) + call lv%set(amg_z_jac_smoother_mold,info,pos='pre') + if (info == 0) call lv%set(amg_z_gs_solver_mold,info,pos='pre') + call lv%set(amg_z_jac_smoother_mold,info,pos='post') + if (info == 0) call lv%set(amg_z_bwgs_solver_mold,info,pos='post') + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if ((ipos_==amg_smooth_pre_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) call lv%sm%default() end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm2a)) call lv%sm2a%default() + end if + + + case('SUB_SOLVE') + select case (val) + case (amg_f_none_) + call lv%set(amg_z_id_solver_mold,info,pos=pos) + + case (amg_diag_scale_) + call lv%set(amg_z_diag_solver_mold,info,pos=pos) + + case (amg_l1_diag_scale_) + call lv%set(amg_z_l1_diag_solver_mold,info,pos=pos) + + case (amg_gs_) + call lv%set(amg_z_gs_solver_mold,info,pos=pos) + + case (amg_bwgs_) + call lv%set(amg_z_bwgs_solver_mold,info,pos=pos) + + case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_) + call lv%set(amg_z_ilu_solver_mold,info,pos=pos) + if (info == 0) then + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + call lv%sm%sv%set('SUB_SOLVE',val,info) + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + end if + end if #ifdef AMG_HAVE_SLU - case (amg_slu_) - call lv%set(amg_z_slu_solver_mold,info,pos=pos) + case (amg_slu_) + call lv%set(amg_z_slu_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_MUMPS - case (amg_mumps_) - call lv%set(amg_z_mumps_solver_mold,info,pos=pos) + case (amg_mumps_) + call lv%set(amg_z_mumps_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_SLUDIST - case (amg_sludist_) - call lv%set(amg_z_sludist_solver_mold,info,pos=pos) + case (amg_sludist_) + call lv%set(amg_z_sludist_solver_mold,info,pos=pos) #endif #ifdef AMG_HAVE_UMF - case (amg_umf_) - call lv%set(amg_z_umf_solver_mold,info,pos=pos) + case (amg_umf_) + call lv%set(amg_z_umf_solver_mold,info,pos=pos) #endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + + + case ('SMOOTHER_SWEEPS') + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_pre = val + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & + & lv%parms%sweeps_post = val + + case ('ML_CYCLE') + lv%parms%ml_cycle = val + + case ('PAR_AGGR_ALG') + lv%parms%par_aggr_alg = val + if (allocated(lv%aggr)) then + call lv%aggr%free(info) + if (info == 0) deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = psb_err_internal_error_ + return + end if + end if + + select case(val) + case(amg_dec_aggr_) + allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info) + case(amg_sym_dec_aggr_) + allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info) + case default + info = psb_err_internal_error_ + end select + if (info == psb_success_) call lv%aggr%default() + + case ('AGGR_ORD') + lv%parms%aggr_ord = val + + case ('AGGR_TYPE') + lv%parms%aggr_type = val + if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) + + case ('AGGR_PROL') + lv%parms%aggr_prol = val + + case ('COARSE_MAT') + lv%parms%coarse_mat = val + + case ('AGGR_OMEGA_ALG') + lv%parms%aggr_omega_alg= val + + case ('AGGR_EIG') + lv%parms%aggr_eig = val + + case ('AGGR_FILTER') + lv%parms%aggr_filter = val + + case ('COARSE_SOLVE') + lv%parms%coarse_solve = val + case default - ! - ! Do nothing and hope for the best :) - ! + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if + end if + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + end select - - - case ('SMOOTHER_SWEEPS') - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_pre = val - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_)) & - & lv%parms%sweeps_post = val - - case ('ML_CYCLE') - lv%parms%ml_cycle = val - - case ('PAR_AGGR_ALG') - lv%parms%par_aggr_alg = val - if (allocated(lv%aggr)) then - call lv%aggr%free(info) - if (info == 0) deallocate(lv%aggr,stat=info) - if (info /= 0) then - info = psb_err_internal_error_ - return - end if - end if - - select case(val) - case(amg_dec_aggr_) - allocate(amg_z_dec_aggregator_type :: lv%aggr, stat=info) - case(amg_sym_dec_aggr_) - allocate(amg_z_symdec_aggregator_type :: lv%aggr, stat=info) - case default - info = psb_err_internal_error_ - end select - if (info == psb_success_) call lv%aggr%default() - - case ('AGGR_ORD') - lv%parms%aggr_ord = val - - case ('AGGR_TYPE') - lv%parms%aggr_type = val - if (allocated(lv%aggr)) call lv%aggr%set_aggr_type(lv%parms,info) - - case ('AGGR_PROL') - lv%parms%aggr_prol = val - - case ('COARSE_MAT') - lv%parms%coarse_mat = val - - case ('AGGR_OMEGA_ALG') - lv%parms%aggr_omega_alg= val - - case ('AGGR_EIG') - lv%parms%aggr_eig = val - - case ('AGGR_FILTER') - lv%parms%aggr_filter = val - - case ('COARSE_SOLVE') - lv%parms%coarse_solve = val - - case default - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) - end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) - end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - - end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_z_base_onelev_cseti + end subroutine amg_z_base_onelev_cseti +end submodule amg_z_base_onelev_cseti_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_csetr.f90 b/amgprec/impl/level/amg_z_base_onelev_csetr.f90 index 5dbb7be0..8e1cdfa9 100644 --- a/amgprec/impl/level/amg_z_base_onelev_csetr.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_csetr.f90 @@ -35,71 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_csetr_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_csetr + +contains + module subroutine amg_z_base_onelev_csetr(lv,what,val,info,pos,idx) - Implicit None + Implicit None - ! Arguments - class(amg_z_onelev_type), intent(inout) :: lv - character(len=*), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - integer(psb_ipk_), intent(in), optional :: idx - ! Local - integer(psb_ipk_) :: ipos_, err_act - character(len=20) :: name='z_base_onelev_csetr' + ! Arguments + class(amg_z_onelev_type), intent(inout) :: lv + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + integer(psb_ipk_), intent(in), optional :: idx + ! Local + integer(psb_ipk_) :: ipos_, err_act + character(len=20) :: name='z_base_onelev_csetr' - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ - select case (psb_toupper(what)) + select case (psb_toupper(what)) - case ('AGGR_OMEGA_VAL') - lv%parms%aggr_omega_val= val + case ('AGGR_OMEGA_VAL') + lv%parms%aggr_omega_val= val - case ('AGGR_THRESH') - lv%parms%aggr_thresh = val + case ('AGGR_THRESH') + lv%parms%aggr_thresh = val - case default - - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + case default + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info,idx=idx) end if - end if - if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then - if (allocated(lv%sm2a)) then - call lv%sm2a%set(what,val,info,idx=idx) + + if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info,idx=idx) + end if end if - end if - if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) + if ((ipos_==amg_smooth_post_).or.(ipos_==amg_smooth_both_))then + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info,idx=idx) + end if + end if + if (allocated(lv%aggr)) call lv%aggr%set(what,val,info,idx=idx) - end select + end select - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_z_base_onelev_csetr + end subroutine amg_z_base_onelev_csetr +end submodule amg_z_base_onelev_csetr_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_descr.f90 b/amgprec/impl/level/amg_z_base_onelev_descr.f90 index d0e9ef2f..84ed753c 100644 --- a/amgprec/impl/level/amg_z_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_descr.f90 @@ -42,114 +42,116 @@ ! 0: normal ! >1: increased details ! -subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_descr_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_descr - Implicit None - ! Arguments - class(amg_z_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - integer(psb_ipk_), intent(in), optional :: verbosity - character(len=*), intent(in), optional :: prefix - - - ! Local variables - integer(psb_ipk_) :: err_act - character(len=20), parameter :: name='amg_z_base_onelev_descr' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse - character(1024) :: prefix_ - type(psb_ctxt_type) :: pctxt - integer(psb_ipk_) :: pme, pnp - - - call psb_erractionsave(err_act) - - - coarse = (il==nl) - - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - - pctxt = lv%desc_ac%get_ctxt() - call psb_info(pctxt,pme,pnp) - write(iout_,*) trim(prefix_) - write(iout_,*) 'At level :',il,' we have ',pnp,' processes' - write(iout_,*) trim(prefix_) - if (il == ilmin) then - call lv%parms%mlcycledsc(iout_,info) - end if - if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then - if (allocated(lv%aggr)) then - call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) - else - write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' - info = psb_err_internal_error_ - call psb_errpush(info,name) - goto 9999 +contains + module subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) + Implicit None + ! Arguments + class(amg_z_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + integer(psb_ipk_), intent(in), optional :: verbosity + character(len=*), intent(in), optional :: prefix + + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='amg_z_base_onelev_descr' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse + character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp + + + call psb_erractionsave(err_act) + + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 + end if + if (verbosity_ < 0) goto 9998 + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) write(iout_,*) trim(prefix_) - end if - - if (il > 1) then - - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' + write(iout_,*) trim(prefix_) + if (il == ilmin) then + call lv%parms%mlcycledsc(iout_,info) end if - - call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) - - if (nl > 1) then - if (allocated(lv%linmap%naggr)) then - write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & - & lv%linmap%nagtot - write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot - if (verbosity_>0) then - write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & - & lv%linmap%naggr(:) - else - write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& - & ' Local matrix sizes: min:', & - & lv%linmap%nagmin,' max:', lv%linmap%nagmax - write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& - & ' avg:', & - & lv%linmap%nagavg - end if - write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& - & ' Aggregation ratio: ', & - & lv%szratio + if (((ilmin==1).and.(il==2)).or.((ilmin>1).and.(il==ilmin))) then + if (allocated(lv%aggr)) then + call lv%aggr%descr(lv%parms,iout_,info,prefix=prefix) + else + write(iout_,*) trim(prefix_),' ', 'Internal error: unallocated aggregator object' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 end if + write(iout_,*) trim(prefix_) end if - if (coarse.and.allocated(lv%sm)) & - & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) - end if + if (il > 1) then + + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + + call lv%parms%descr(iout_,info,coarse=coarse,prefix=prefix) + + if (nl > 1) then + if (allocated(lv%linmap%naggr)) then + write(iout_,*) trim(prefix_), ' Coarse Matrix: Global size: ', & + & lv%linmap%nagtot + write(iout_,*) trim(prefix_), ' Nonzeros: ',lv%ac_nz_tot + if (verbosity_>0) then + write(iout_,*) trim(prefix_), ' Local matrix sizes: ', & + & lv%linmap%naggr(:) + else + write(iout_,'(a,1x,2(a,1x,i12))') trim(prefix_),& + & ' Local matrix sizes: min:', & + & lv%linmap%nagmin,' max:', lv%linmap%nagmax + write(iout_,'(a,1x,a,1x,f14.1)') trim(prefix_),& + & ' avg:', & + & lv%linmap%nagavg + end if + write(iout_,'(a,1x,a,1x,f14.2)') trim(prefix_),& + & ' Aggregation ratio: ', & + & lv%szratio + end if + end if + + if (coarse.and.allocated(lv%sm)) & + & call lv%sm%descr(info,iout=iout_,coarse=coarse,prefix=prefix) + end if 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_z_base_onelev_descr + end subroutine amg_z_base_onelev_descr +end submodule amg_z_base_onelev_descr_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_dump.f90 b/amgprec/impl/level/amg_z_base_onelev_dump.f90 index 2a5bf266..0fa57681 100644 --- a/amgprec/impl/level/amg_z_base_onelev_dump.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_dump.f90 @@ -35,135 +35,137 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& - & smoother,solver,tprol,global_num) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_dump_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_dump - implicit none - class(amg_z_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: level - integer(psb_ipk_), intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num - ! Local variables - integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: iam, np - character(len=80) :: prefix_, frmt - character(len=1024) :: fname - logical :: ac_, rp_, tprol_, global_num_ - integer(psb_lpk_), allocatable :: ivr(:), ivc(:) - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_lev_z" - end if - - if (associated(lv%base_desc)) then - ctxt = lv%base_desc%get_context() - call psb_info(ctxt,iam,np) - else - iam = -1 - np = -1 - end if - if (present(ac)) then - ac_ = ac - else - ac_ = .false. - end if - if (present(rp)) then - rp_ = rp - else - rp_ = .false. - end if - if (present(tprol)) then - tprol_ = tprol - else - tprol_ = .false. - end if - if (present(global_num)) then - global_num_ = global_num - else - global_num_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - - if (np > 0) then - ni = floor(log10(1.0*np)) + 1 - write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' - write(fname(lname+1:lname+ni+2),frmt) '_p',iam - lname = lname + ni + 2 - end if - - if (global_num_) then - if (level == 1) then - if (ac_) then - ivr = lv%base_desc%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head,iv=ivr) - end if - else if (level >= 2) then - if (ac_) then - ivr = lv%desc_ac%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head,iv=ivr) - end if - if (rp_) then - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) - end if - if (tprol_) then - ! Tentative prolongator is stored with column indices already - ! in global numbering, so only IVR is needed. - ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head,ivr=ivr) - end if - end if - else - if (level == 1) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%base_a%print(fname,head=head) - end if - else if (level >= 2) then - if (ac_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' - call lv%ac%print(fname,head=head) - end if - if (rp_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' - call lv%linmap%mat_U2V%print(fname,head=head) - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' - call lv%linmap%mat_V2U%print(fname,head=head) - end if - if (tprol_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' - ! - call lv%tprol%print(fname,head=head) - end if - end if - end if - if (level >= 1) then - if (allocated(lv%sm)) then - call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) +contains + module subroutine amg_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,& + & smoother,solver,tprol,global_num) + implicit none + class(amg_z_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: level + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: ac, rp, smoother, solver, tprol, global_num + ! Local variables + integer(psb_ipk_) :: i, j, il1, iln, lname, lev, ni + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np + character(len=80) :: prefix_, frmt + character(len=1024) :: fname + logical :: ac_, rp_, tprol_, global_num_ + integer(psb_lpk_), allocatable :: ivr(:), ivc(:) + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_lev_z" end if - if (allocated(lv%sm2a)) then - call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & - & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + + if (associated(lv%base_desc)) then + ctxt = lv%base_desc%get_context() + call psb_info(ctxt,iam,np) + else + iam = -1 + np = -1 end if - end if - -end subroutine amg_z_base_onelev_dump + if (present(ac)) then + ac_ = ac + else + ac_ = .false. + end if + if (present(rp)) then + rp_ = rp + else + rp_ = .false. + end if + if (present(tprol)) then + tprol_ = tprol + else + tprol_ = .false. + end if + if (present(global_num)) then + global_num_ = global_num + else + global_num_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + + if (np > 0) then + ni = floor(log10(1.0*np)) + 1 + write(frmt,'(a,i3.3,a,i3.3,a)') '(a,i',ni,'.',ni,')' + write(fname(lname+1:lname+ni+2),frmt) '_p',iam + lname = lname + ni + 2 + end if + + if (global_num_) then + if (level == 1) then + if (ac_) then + ivr = lv%base_desc%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head,iv=ivr) + end if + else if (level >= 2) then + if (ac_) then + ivr = lv%desc_ac%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head,iv=ivr) + end if + if (rp_) then + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + ivc = lv%linmap%p_desc_V%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head,ivr=ivc,ivc=ivr) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head,ivr=ivr,ivc=ivc) + end if + if (tprol_) then + ! Tentative prolongator is stored with column indices already + ! in global numbering, so only IVR is needed. + ivr = lv%linmap%p_desc_U%get_global_indices(owned=.false.) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head,ivr=ivr) + end if + end if + else + if (level == 1) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%base_a%print(fname,head=head) + end if + else if (level >= 2) then + if (ac_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' + call lv%ac%print(fname,head=head) + end if + if (rp_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_r.mtx' + call lv%linmap%mat_U2V%print(fname,head=head) + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_p.mtx' + call lv%linmap%mat_V2U%print(fname,head=head) + end if + if (tprol_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_tprol.mtx' + ! + call lv%tprol%print(fname,head=head) + end if + end if + end if + + if (level >= 1) then + if (allocated(lv%sm)) then + call lv%sm%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm",global_num=global_num) + end if + if (allocated(lv%sm2a)) then + call lv%sm2a%dump(lv%base_desc,level,info,smoother=smoother, & + & solver=solver,prefix=trim(prefix_)//"_sm2a",global_num=global_num) + end if + end if + + end subroutine amg_z_base_onelev_dump +end submodule amg_z_base_onelev_dump_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_free.f90 b/amgprec/impl/level/amg_z_base_onelev_free.f90 index ceb1f829..1b76f3ce 100644 --- a/amgprec/impl/level/amg_z_base_onelev_free.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_free.f90 @@ -35,41 +35,43 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_free(lv,info) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_free_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_free - implicit none + +contains + module subroutine amg_z_base_onelev_free(lv,info) + implicit none - class(amg_z_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_z_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) - if (allocated(lv%wrk)) & - & call lv%wrk%free(info) + if (allocated(lv%wrk)) & + & call lv%wrk%free(info) - call lv%ac%free() - if (lv%desc_ac%is_ok()) & - & call lv%desc_ac%free(info) - call lv%linmap%free(info) + call lv%ac%free() + if (lv%desc_ac%is_ok()) & + & call lv%desc_ac%free(info) + call lv%linmap%free(info) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_a) - ! This is a pointer to something else, must not free it here. - nullify(lv%base_desc) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_a) + ! This is a pointer to something else, must not free it here. + nullify(lv%base_desc) - call lv%nullify() + call lv%nullify() -end subroutine amg_z_base_onelev_free + end subroutine amg_z_base_onelev_free +end submodule amg_z_base_onelev_free_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_free_smoothers.f90 b/amgprec/impl/level/amg_z_base_onelev_free_smoothers.f90 index 6e91c879..a975131b 100644 --- a/amgprec/impl/level/amg_z_base_onelev_free_smoothers.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_free_smoothers.f90 @@ -35,26 +35,28 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_free_smoothers(lv,info) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_dree_smoothers_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_free_smoothers - implicit none + +contains + module subroutine amg_z_base_onelev_free_smoothers(lv,info) + implicit none - class(amg_z_onelev_type), intent(inout) :: lv - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + class(amg_z_onelev_type), intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i - info = psb_success_ + info = psb_success_ - ! We might just deallocate the top level array, except - ! that there may be inner objects containing C pointers, - ! e.g. UMFPACK, SLU or CUDA stuff. - ! We really need FINALs. - if (allocated(lv%sm)) & - & call lv%sm%free(info) + ! We might just deallocate the top level array, except + ! that there may be inner objects containing C pointers, + ! e.g. UMFPACK, SLU or CUDA stuff. + ! We really need FINALs. + if (allocated(lv%sm)) & + & call lv%sm%free(info) - if (allocated(lv%sm2a)) & - & call lv%sm2a%free(info) + if (allocated(lv%sm2a)) & + & call lv%sm2a%free(info) -end subroutine amg_z_base_onelev_free_smoothers + end subroutine amg_z_base_onelev_free_smoothers +end submodule amg_z_base_onelev_dree_smoothers_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_map_prol.F90 b/amgprec/impl/level/amg_z_base_onelev_map_prol.F90 index 0a7d8029..52b2800d 100644 --- a/amgprec/impl/level/amg_z_base_onelev_map_prol.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_map_prol.F90 @@ -35,112 +35,113 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) - use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_prol_v - - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_z_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), optional :: work(:) - type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_z_vect_type), pointer :: vtx_ +submodule (amg_z_onelev_mod) amg_z_base_onelev_map_prol_impl + use psb_base_mod + +contains + module subroutine amg_z_base_onelev_map_prol_v(lv,alpha,vect_v,beta,vect_u,info,work,vtx,vty) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_z_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), optional :: work(:) + type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty + + type(psb_z_vect_type), pointer :: vtx_ !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vtx)) then - vtx_ => vtx - else - vtx_ => lv%wrk%wv(1) - end if - -!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! -!!$ write(0,*) 'Remap handling ' - block - type(psb_ctxt_type) :: ctxt, nctxt - integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp - integer(psb_mpk_) :: me, np, rme, rnp - complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:) - type(psb_z_vect_type) :: tv + if (present(vtx)) then + vtx_ => vtx + else + vtx_ => lv%wrk%wv(1) + end if - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) +!!$ write(0,*) 'New map_prol',lv%remap_data%ac_pre_remap%is_asb() + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! +!!$ write(0,*) 'Remap handling ' + block + type(psb_ctxt_type) :: ctxt, nctxt + integer(psb_mpk_) :: i,j,ip,idest, nsrc, nrl, nrc, kp + integer(psb_mpk_) :: me, np, rme, rnp +complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:) + type(psb_z_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) 'Old context ',me,np,psb_errstatus_fatal() - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + nctxt = lv%desc_ac%get_ctxt() + call psb_info(nctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp,psb_errstatus_fatal() - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then receive data from ',idest,' to ',me,psb_errstatus_fatal() - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) - rrcv = vect_v%get_vect() + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + nrc = lv%remap_data%desc_ac_pre_remap%get_local_cols() + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) + rrcv = vect_v%get_vect() !!$ write(0,*) me,rme,' Size check ',size(rrcv),lv%desc_ac%get_local_rows(),psb_errstatus_fatal() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' Sending to ',ip,nrl,kp+1,kp+nrl - call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - end if - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_snd(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + end if + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) !!$ write(0,*) me, ' Allocated ',nrl,info,psb_errstatus_fatal() - - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' Size of TV ',nrl,tv%get_nrows(),info !!$ write(0,*) me,' Receiving from ',idest,nrl,psb_errstatus_fatal() !!$ call psb_realloc(nrc,rsnd,info) !!$ call psb_rcv(ctxt,rsnd(1:nrl),idest) !!$ call tv%set_vect(rsnd) - call psb_rcv(ctxt,tv%v%v(1:nrl),idest) - call tv%set_host() - call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end associate + call psb_rcv(ctxt,tv%v%v(1:nrl),idest) + call tv%set_host() + call lv%linmap%map_V2U(alpha,tv,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end associate !!$ write(0,*) me, ' Prolongator with remap done ' !!$ flush(0) !!$ call psb_barrier(ctxt) - end block - else - ! Default transfer - call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& - & work=work,vtx=vtx_,vty=vty) - end if - -end subroutine amg_z_base_onelev_map_prol_v + end block + else + ! Default transfer + call lv%linmap%map_V2U(alpha,vect_v,beta,vect_u,info,& + & work=work,vtx=vtx_,vty=vty) + end if -subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) - use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_prol_a - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv - complex(psb_dpk_), intent(in) :: alpha, beta - complex(psb_dpk_), intent(inout) :: u(:) - complex(psb_dpk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), optional :: work(:) + end subroutine amg_z_base_onelev_map_prol_v - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap P handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_V2U(alpha,v,beta,u,info,& - & work=work) - end if - -end subroutine amg_z_base_onelev_map_prol_a + module subroutine amg_z_base_onelev_map_prol_a(lv,alpha,v,beta,u,info,work) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + complex(psb_dpk_), intent(in) :: alpha, beta + complex(psb_dpk_), intent(inout) :: u(:) + complex(psb_dpk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), optional :: work(:) + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap P handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_V2U(alpha,v,beta,u,info,& + & work=work) + end if + + end subroutine amg_z_base_onelev_map_prol_a +end submodule amg_z_base_onelev_map_prol_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 index 808752fd..7897cea9 100644 --- a/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 @@ -36,114 +36,115 @@ ! ! -subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& - & work,vtx,vty) +submodule (amg_z_onelev_mod) amg_z_base_onelev_map_rstr_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_rstr_v - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_z_vect_type), intent(inout) :: vect_u, vect_v - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), optional :: work(:) - type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty - type(psb_z_vect_type), pointer :: vty_ - integer(psb_mpk_) :: me, np + +contains + module subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& + & work,vtx,vty) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_z_vect_type), intent(inout) :: vect_u, vect_v + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), optional :: work(:) + type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty + type(psb_z_vect_type), pointer :: vty_ + integer(psb_mpk_) :: me, np !!$ write(0,*) 'New map_rstr',lv%remap_data%ac_pre_remap%is_asb() - if (present(vty)) then - vty_ => vty - else - vty_ => lv%wrk%wv(1) - end if - - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! + if (present(vty)) then + vty_ => vty + else + vty_ => lv%wrk%wv(1) + end if + + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! !!$ write(0,*) 'Remap handling not implemented yet ' - block - type(psb_ctxt_type) :: ctxt, rctxt - integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp - integer(psb_mpk_) :: rme, rnp - complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:) - type(psb_z_vect_type) :: tv - - ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() - call psb_info(ctxt,me,np) - rctxt = lv%desc_ac%get_ctxt() - call psb_info(rctxt,rme,rnp) + block + type(psb_ctxt_type) :: ctxt, rctxt + integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp + integer(psb_mpk_) :: rme, rnp +complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:) + type(psb_z_vect_type) :: tv + + ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() + call psb_info(ctxt,me,np) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context map rstr',rme,rnp,me,np - idest = lv%remap_data%idest - associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) + idest = lv%remap_data%idest + associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) !!$ write(0,*) 'Should apply maps, then send data from ',me,' to ',idest !!$ if (rme >= 0) write(0,*) rme, ' Receiving data from ',isrc(:) - nsrc = size(isrc) - nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() - call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) - call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) + nsrc = size(isrc) + nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() + call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) + call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) !!$ write(0,*) me,' remap map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows(),& !!$ & psb_errstatus_fatal() !!$ flush(0) - call psb_barrier(ctxt) - call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& - & work=work,vtx=vtx,vty=vty_) - call tv%sync() - !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + call psb_barrier(ctxt) + call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& + & work=work,vtx=vtx,vty=vty_) + call tv%sync() + !rsnd = tv%get_vect() + !call psb_snd(ctxt,rsnd(1:nrl),idest) !!$ write(0,*) me,' map_rstr sending ',me,idest,psb_errstatus_fatal() - call psb_snd(ctxt,tv%v%v(1:nrl),idest) - if (rme >=0) then - allocate(rrcv(sum(nrsrc))) + call psb_snd(ctxt,tv%v%v(1:nrl),idest) + if (rme >=0) then + allocate(rrcv(sum(nrsrc))) !!$ write(0,*) me,rme,' Size check ',size(rrcv)!,lv%desc_ac%get_local_rows() - kp = 0 - do i = 1,size(isrc) - ip = isrc(i) - nrl = nrsrc(i) + kp = 0 + do i = 1,size(isrc) + ip = isrc(i) + nrl = nrsrc(i) !!$ write(0,*) me,' map_rstr receiving',rme,ip,psb_errstatus_fatal() - call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) - kp = kp + nrl - end do - call vect_v%set_vect(rrcv) - end if - end associate + call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) + kp = kp + nrl + end do + call vect_v%set_vect(rrcv) + end if + end associate !!$ write(0,*) me, ' Restrictor with remap done ',psb_errstatus_fatal() - end block - - else - ! Default transfer - block - type(psb_ctxt_type) :: ctxt, rctxt - ctxt = lv%linmap%p_desc_U%get_ctxt() - call psb_info(ctxt,me,np) + end block + + else + ! Default transfer + block + type(psb_ctxt_type) :: ctxt, rctxt + ctxt = lv%linmap%p_desc_U%get_ctxt() + call psb_info(ctxt,me,np) !!$ write(0,*) me,' map_rstr calling U2V: ',me,np - call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& - & work=work,vtx=vtx,vty=vty_) - end block - end if + call lv%linmap%map_U2V(alpha,vect_u,beta,vect_v,info,& + & work=work,vtx=vtx,vty=vty_) + end block + end if !!$ write(0,*) me, 'End of restriction ',info,psb_errstatus_fatal() -end subroutine amg_z_base_onelev_map_rstr_v + end subroutine amg_z_base_onelev_map_rstr_v -subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) - use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_map_rstr_a - implicit none - class(amg_z_onelev_type), target, intent(inout) :: lv - complex(psb_dpk_), intent(in) :: alpha, beta - complex(psb_dpk_), intent(inout) :: u(:) - complex(psb_dpk_), intent(out) :: v(:) - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), optional :: work(:) + module subroutine amg_z_base_onelev_map_rstr_a(lv,alpha,u,beta,v,info,work) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + complex(psb_dpk_), intent(in) :: alpha, beta + complex(psb_dpk_), intent(inout) :: u(:) + complex(psb_dpk_), intent(out) :: v(:) + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), optional :: work(:) - if (lv%remap_data%ac_pre_remap%is_asb()) then - ! - ! Remap has happened, deal with it - ! - write(0,*) 'Remap R handling not implemented yet for A' - else - ! Default transfer - call lv%linmap%map_U2V(alpha,u,beta,v,info,& - & work=work) - end if - -end subroutine amg_z_base_onelev_map_rstr_a + if (lv%remap_data%ac_pre_remap%is_asb()) then + ! + ! Remap has happened, deal with it + ! + write(0,*) 'Remap R handling not implemented yet for A' + else + ! Default transfer + call lv%linmap%map_U2V(alpha,u,beta,v,info,& + & work=work) + end if + + end subroutine amg_z_base_onelev_map_rstr_a +end submodule amg_z_base_onelev_map_rstr_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_mat_asb.f90 b/amgprec/impl/level/amg_z_base_onelev_mat_asb.f90 index 9cadc259..306cf8cf 100644 --- a/amgprec/impl/level/amg_z_base_onelev_mat_asb.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_mat_asb.f90 @@ -83,109 +83,111 @@ ! info - integer, output. ! Error code. ! -subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_mat_asb_impl use psb_base_mod use amg_base_prec_type - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_mat_asb - - implicit none - - ! Arguments - class(amg_z_onelev_type), intent(inout), target :: lv - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(inout) :: desc_a - integer(psb_lpk_), intent(inout) :: nlaggr(:) - integer(psb_lpk_), intent(inout) :: ilaggr(:) - type(psb_lzspmat_type), intent(inout) :: t_prol - integer(psb_ipk_), intent(out) :: info +contains + module subroutine amg_z_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info) - ! Local variables - character(len=24) :: name - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - type(psb_zspmat_type) :: ac, op_restr, op_prol - integer(psb_ipk_) :: nzl, inl - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 - logical, parameter :: do_timings=.false. + implicit none - name='amg_z_onelev_mat_asb' - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_; goto 9999 - end if - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - info = psb_success_ - ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) - if ((do_timings).and.(idx_matbld==-1)) & - & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") - if ((do_timings).and.(idx_matasb==-1)) & - & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") - if ((do_timings).and.(idx_mapbld==-1)) & - & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - - call amg_check_def(lv%parms%aggr_prol,'Smoother',& - & amg_smooth_prol_,is_legal_ml_aggr_prol) - call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& - & amg_distr_mat_,is_legal_ml_coarse_mat) - call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& - & amg_no_filter_mat_,is_legal_aggr_filter) - call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& - & amg_eig_est_,is_legal_ml_aggr_omega_alg) - call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& - & amg_max_norm_,is_legal_ml_aggr_eig) - call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + ! Arguments + class(amg_z_onelev_type), intent(inout), target :: lv + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(inout) :: nlaggr(:) + integer(psb_lpk_), intent(inout) :: ilaggr(:) + type(psb_lzspmat_type), intent(inout) :: t_prol + integer(psb_ipk_), intent(out) :: info - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by lv%iprcparm(amg_aggr_prol_) - ! - if (do_timings) call psb_tic(idx_matbld) - call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& - & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) - if (do_timings) call psb_toc(idx_matbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') - goto 9999 - end if + ! Local variables + character(len=24) :: name + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + type(psb_zspmat_type) :: ac, op_restr, op_prol + integer(psb_ipk_) :: nzl, inl + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1 + logical, parameter :: do_timings=.false. - ! - ! Now build its descriptor and convert global indices for - ! ac, op_restr and op_prol - ! - if (do_timings) call psb_tic(idx_matasb) - if (info == psb_success_) & - & call lv%aggr%mat_asb(lv%parms,a,desc_a,& - & lv%ac,lv%desc_ac,op_prol,op_restr,info) - if (do_timings) call psb_toc(idx_matasb) - if (do_timings) call psb_tic(idx_mapbld) - if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - - if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& - & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) - if (do_timings) call psb_toc(idx_mapbld) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') - goto 9999 - end if - ! - ! Fix the base_a and base_desc pointers for handling of residuals. - ! This is correct because this routine is only called at levels >=2. - ! - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac + name='amg_z_onelev_mat_asb' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if ((do_timings).and.(idx_matbld==-1)) & + & idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld") + if ((do_timings).and.(idx_matasb==-1)) & + & idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb") + if ((do_timings).and.(idx_mapbld==-1)) & + & idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld") - call psb_erractionrestore(err_act) - return + call amg_check_def(lv%parms%aggr_prol,'Smoother',& + & amg_smooth_prol_,is_legal_ml_aggr_prol) + call amg_check_def(lv%parms%coarse_mat,'Coarse matrix',& + & amg_distr_mat_,is_legal_ml_coarse_mat) + call amg_check_def(lv%parms%aggr_filter,'Use filtered matrix',& + & amg_no_filter_mat_,is_legal_aggr_filter) + call amg_check_def(lv%parms%aggr_omega_alg,'Omega Alg.',& + & amg_eig_est_,is_legal_ml_aggr_omega_alg) + call amg_check_def(lv%parms%aggr_eig,'Eigenvalue estimate',& + & amg_max_norm_,is_legal_ml_aggr_eig) + call amg_check_def(lv%parms%aggr_omega_val,'Omega',dzero,is_legal_d_omega) + + + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by lv%iprcparm(amg_aggr_prol_) + ! + if (do_timings) call psb_tic(idx_matbld) + call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,& + & lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info) + if (do_timings) call psb_toc(idx_matbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb') + goto 9999 + end if + + ! + ! Now build its descriptor and convert global indices for + ! ac, op_restr and op_prol + ! + if (do_timings) call psb_tic(idx_matasb) + if (info == psb_success_) & + & call lv%aggr%mat_asb(lv%parms,a,desc_a,& + & lv%ac,lv%desc_ac,op_prol,op_restr,info) + if (do_timings) call psb_toc(idx_matasb) + if (do_timings) call psb_tic(idx_mapbld) + if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + + if (info == psb_success_) call lv%aggr%bld_linmap(desc_a, lv%desc_ac,& + & ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info) + if (do_timings) call psb_toc(idx_mapbld) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld') + goto 9999 + end if + ! + ! Fix the base_a and base_desc pointers for handling of residuals. + ! This is correct because this routine is only called at levels >=2. + ! + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_z_base_onelev_mat_asb + end subroutine amg_z_base_onelev_mat_asb +end submodule amg_z_base_onelev_mat_asb_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 index 105eade1..668b351c 100644 --- a/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_memory_use.f90 @@ -42,109 +42,112 @@ ! 0: normal ! >1: increased details ! -subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_memory_use_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_memory_use - Implicit None - ! Arguments - class(amg_z_onelev_type), intent(in) :: lv - integer(psb_ipk_), intent(in) :: il,nl,ilmin - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iout - character(len=*), intent(in), optional :: prefix - integer(psb_ipk_), intent(in), optional :: verbosity - logical, intent(in), optional :: global - - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: err_act ,me, np - character(len=20), parameter :: name='amg_z_base_onelev_memory_use' - integer(psb_ipk_) :: iout_, verbosity_ - logical :: coarse, global_ - character(1024) :: prefix_ - integer(psb_epk_), allocatable :: sz(:) - - - call psb_erractionsave(err_act) - - ctxt = lv%base_desc%get_ctxt() - call psb_info(ctxt,me,np) - coarse = (il==nl) +contains + module subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,& + & iout,verbosity,prefix,global) + Implicit None + ! Arguments + class(amg_z_onelev_type), intent(in) :: lv + integer(psb_ipk_), intent(in) :: il,nl,ilmin + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + character(len=*), intent(in), optional :: prefix + integer(psb_ipk_), intent(in), optional :: verbosity + logical, intent(in), optional :: global - if (present(iout)) then - iout_ = iout - else - iout_ = psb_out_unit - end if - if (present(verbosity)) then - verbosity_ = verbosity - else - verbosity_ = 0 - end if - if (verbosity_ < 0) goto 9998 - if (present(global)) then - global_ = global - else - global_ = .true. - end if + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act ,me, np + character(len=20), parameter :: name='amg_z_base_onelev_memory_use' + integer(psb_ipk_) :: iout_, verbosity_ + logical :: coarse, global_ + character(1024) :: prefix_ + integer(psb_epk_), allocatable :: sz(:) - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + call psb_erractionsave(err_act) - if (global_) then - allocate(sz(6)) - sz(:) = 0 - sz(1) = lv%base_a%sizeof() - sz(2) = lv%base_desc%sizeof() - if (il >1) sz(3) = lv%linmap%sizeof() - if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() - if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() - if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() - call psb_sum(ctxt,sz) - if (me == 0) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', sz(1) - write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + ctxt = lv%base_desc%get_ctxt() + call psb_info(ctxt,me,np) + + coarse = (il==nl) + + if (present(iout)) then + iout_ = iout + else + iout_ = psb_out_unit end if - - else - if ((me == 0).or.(verbosity_>0)) then - if (coarse) then - write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' - else - write(iout_,*) trim(prefix_), ' Level ',il - end if - write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() - write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() - if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() - if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() - if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() - if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + + if (present(verbosity)) then + verbosity_ = verbosity + else + verbosity_ = 0 end if - endif + if (verbosity_ < 0) goto 9998 + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_) + + if (global_) then + allocate(sz(6)) + sz(:) = 0 + sz(1) = lv%base_a%sizeof() + sz(2) = lv%base_desc%sizeof() + if (il >1) sz(3) = lv%linmap%sizeof() + if (allocated(lv%sm)) sz(4) = lv%sm%sizeof() + if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof() + if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof() + call psb_sum(ctxt,sz) + if (me == 0) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', sz(1) + write(iout_,*) trim(prefix_), ' Descriptor:', sz(2) + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3) + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4) + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5) + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6) + end if + + else + if ((me == 0).or.(verbosity_>0)) then + if (coarse) then + write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)' + else + write(iout_,*) trim(prefix_), ' Level ',il + end if + write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof() + write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof() + if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof() + if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof() + if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof() + if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof() + end if + endif 9998 continue - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(err_act) - return + return -end subroutine amg_z_base_onelev_memory_use + end subroutine amg_z_base_onelev_memory_use +end submodule amg_z_base_onelev_memory_use_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_setag.f90 b/amgprec/impl/level/amg_z_base_onelev_setag.f90 index 3182c6c0..7247030a 100644 --- a/amgprec/impl/level/amg_z_base_onelev_setag.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_setag.f90 @@ -35,48 +35,50 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_setag(lv,val,info,pos) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_setag_impl use psb_base_mod - use amg_z_onelev_mod, amg_protect_name => amg_z_base_onelev_setag - - implicit none - - ! Arguments - class(amg_z_onelev_type), target, intent(inout) :: lv - class(amg_z_base_aggregator_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setag' +contains + module subroutine amg_z_base_onelev_setag(lv,val,info,pos) - info = psb_success_ + implicit none - ! Ignore pos for aggregator - - if (allocated(lv%aggr)) then - if (.not.same_type_as(lv%aggr,val)) then - call lv%aggr%free(info) - deallocate(lv%aggr,stat=info) + ! Arguments + class(amg_z_onelev_type), target, intent(inout) :: lv + class(amg_z_base_aggregator_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setag' + + info = psb_success_ + + ! Ignore pos for aggregator + + if (allocated(lv%aggr)) then + if (.not.same_type_as(lv%aggr,val)) then + call lv%aggr%free(info) + deallocate(lv%aggr,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%aggr)) then + allocate(lv%aggr,mold=val,stat=info) if (info /= 0) then info = 3111 return end if + lv%parms%par_aggr_alg = amg_ext_aggr_ + lv%parms%aggr_type = amg_noalg_ + call lv%aggr%default() end if - end if - - if (.not.allocated(lv%aggr)) then - allocate(lv%aggr,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - lv%parms%par_aggr_alg = amg_ext_aggr_ - lv%parms%aggr_type = amg_noalg_ - call lv%aggr%default() - end if - -end subroutine amg_z_base_onelev_setag + end subroutine amg_z_base_onelev_setag + +end submodule amg_z_base_onelev_setag_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_setsm.F90 b/amgprec/impl/level/amg_z_base_onelev_setsm.F90 index 837d3b3b..1d2491ab 100644 --- a/amgprec/impl/level/amg_z_base_onelev_setsm.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_setsm.F90 @@ -35,72 +35,73 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_setsm(lev,val,info,pos) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_setsm_impl use psb_base_mod - use amg_z_prec_mod, amg_protect_name => amg_z_base_onelev_setsm - - implicit none - - ! Arguments - class(amg_z_onelev_type), target, intent(inout) :: lev - class(amg_z_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsm' - - info = psb_success_ +contains + module subroutine amg_z_base_onelev_setsm(lv,val,info,pos) + implicit none - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Arguments + class(amg_z_onelev_type), target, intent(inout) :: lv + class(amg_z_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if (ipos_ == amg_smooth_both_) then - if (allocated(lev%sm2a)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - lev%sm2 => null() end if - end if - - select case(ipos_) - case(amg_smooth_pre_, amg_smooth_both_) - if (allocated(lev%sm)) then - if (.not.same_type_as(lev%sm,val)) then - call lev%sm%free(info) - deallocate(lev%sm, stat=info) + + if (ipos_ == amg_smooth_both_) then + if (allocated(lv%sm2a)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + lv%sm2 => null() end if - endif - if (.not.allocated(lev%sm)) then - allocate(lev%sm,mold=val) end if - call lev%sm%default() - if (ipos_ == amg_smooth_both_) lev%sm2 => lev%sm - case(amg_smooth_post_) - if (allocated(lev%sm2a)) then - if (.not.same_type_as(lev%sm2a,val)) then - call lev%sm2a%free(info) - deallocate(lev%sm2a, stat=info) - endif - end if - if (.not.allocated(lev%sm2a)) then - allocate(lev%sm2a,mold=val) - end if - call lev%sm2a%default() - lev%sm2 => lev%sm2a - end select - -end subroutine amg_z_base_onelev_setsm + select case(ipos_) + case(amg_smooth_pre_, amg_smooth_both_) + if (allocated(lv%sm)) then + if (.not.same_type_as(lv%sm,val)) then + call lv%sm%free(info) + deallocate(lv%sm, stat=info) + end if + endif + if (.not.allocated(lv%sm)) then + allocate(lv%sm,mold=val) + end if + call lv%sm%default() + if (ipos_ == amg_smooth_both_) lv%sm2 => lv%sm + case(amg_smooth_post_) + if (allocated(lv%sm2a)) then + if (.not.same_type_as(lv%sm2a,val)) then + call lv%sm2a%free(info) + deallocate(lv%sm2a, stat=info) + endif + end if + if (.not.allocated(lv%sm2a)) then + allocate(lv%sm2a,mold=val) + end if + call lv%sm2a%default() + lv%sm2 => lv%sm2a + end select + + end subroutine amg_z_base_onelev_setsm + +end submodule amg_z_base_onelev_setsm_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_setsv.F90 b/amgprec/impl/level/amg_z_base_onelev_setsv.F90 index 46fd2530..53a61983 100644 --- a/amgprec/impl/level/amg_z_base_onelev_setsv.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_setsv.F90 @@ -35,110 +35,111 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine amg_z_base_onelev_setsv(lev,val,info,pos) - +submodule (amg_z_onelev_mod) amg_z_base_onelev_setsv_impl use psb_base_mod - use amg_z_prec_mod, amg_protect_name => amg_z_base_onelev_setsv - - implicit none - - ! Arguments - class(amg_z_onelev_type), target, intent(inout) :: lev - class(amg_z_base_solver_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local variables - integer(psb_ipk_) :: ipos_ - character(len=*), parameter :: name='amg_base_onelev_setsv' +contains + module subroutine amg_z_base_onelev_setsv(lv,val,info,pos) + implicit none - info = psb_success_ + ! Arguments + class(amg_z_onelev_type), target, intent(inout) :: lv + class(amg_z_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = amg_smooth_pre_ - case('POST') - ipos_ = amg_smooth_post_ - case default + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='amg_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = amg_smooth_pre_ + case('POST') + ipos_ = amg_smooth_post_ + case default + ipos_ = amg_smooth_both_ + end select + else ipos_ = amg_smooth_both_ - end select - else - ipos_ = amg_smooth_both_ - end if - - if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then - if (allocated(lev%sm)) then - if (allocated(lev%sm%sv)) then - if (.not.same_type_as(lev%sm%sv,val)) then - call lev%sm%sv%free(info) - if (info == 0) deallocate(lev%sm%sv,stat=info) + end if + + if ((ipos_ == amg_smooth_pre_).or.(ipos_ == amg_smooth_both_)) then + if (allocated(lv%sm)) then + if (allocated(lv%sm%sv)) then + if (.not.same_type_as(lv%sm%sv,val)) then + call lv%sm%sv%free(info) + if (info == 0) deallocate(lv%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lv%sm%sv)) then + allocate(lv%sm%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if + call lv%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + end if - - if (.not.allocated(lev%sm%sv)) then - allocate(lev%sm%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - end if - end if - ! - ! If POS was not specified and therefore we have amg_smooth_both_ - ! we need to update sm2a *only* if it was already allocated, - ! otherwise it is not needed (since we have just fixed %sm in the - ! pre section). - ! + ! + ! If POS was not specified and therefore we have amg_smooth_both_ + ! we need to update sm2a *only* if it was already allocated, + ! otherwise it is not needed (since we have just fixed %sm in the + ! pre section). + ! - if ((ipos_ == amg_smooth_post_).or. & - ((ipos_ == amg_smooth_both_).and.(allocated(lev%sm2a)))) then + if ((ipos_ == amg_smooth_post_).or. & + ((ipos_ == amg_smooth_both_).and.(allocated(lv%sm2a)))) then - if (allocated(lev%sm2a)) then - if (allocated(lev%sm2a%sv)) then - if (.not.same_type_as(lev%sm2a%sv,val)) then - call lev%sm2a%sv%free(info) - if (info == 0) deallocate(lev%sm2a%sv,stat=info) + if (allocated(lv%sm2a)) then + if (allocated(lv%sm2a%sv)) then + if (.not.same_type_as(lv%sm2a%sv,val)) then + call lv%sm2a%sv%free(info) + if (info == 0) deallocate(lv%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lv%sm2a%sv)) then + allocate(lv%sm2a%sv,mold=val,stat=info) if (info /= 0) then info = 3111 return end if end if - end if - if (.not.allocated(lev%sm2a%sv)) then - allocate(lev%sm2a%sv,mold=val,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - call lev%sm2a%sv%default() - - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call amg_PRECINIT/amg_PRECSET' - return - - end if - - end if - -end subroutine amg_z_base_onelev_setsv + call lv%sm2a%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call amg_PRECINIT/amg_PRECSET' + return + + end if + + end if + + end subroutine amg_z_base_onelev_setsv + +end submodule amg_z_base_onelev_setsv_impl diff --git a/amgprec/impl/level/amg_z_base_onelev_wrk_handle.f90 b/amgprec/impl/level/amg_z_base_onelev_wrk_handle.f90 new file mode 100644 index 00000000..90cafbd8 --- /dev/null +++ b/amgprec/impl/level/amg_z_base_onelev_wrk_handle.f90 @@ -0,0 +1,333 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +submodule (amg_z_onelev_mod) amg_z_base_onelev_wrk_handle_impl + use psb_base_mod + +contains + + module subroutine z_base_onelev_move_alloc(lv, b,info) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + b%parms = lv%parms + b%szratio = lv%szratio + if (associated(lv%sm2,lv%sm2a)) then + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(lv%sm,b%sm) + call move_alloc(lv%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + + call move_alloc(lv%aggr,b%aggr) + if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(lv%tprol,b%tprol,info) + if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(lv%linmap,b%linmap,info) + if (info == psb_success_) call lv%remap_data%move_alloc(b%remap_data,info) + b%base_a => lv%base_a + b%base_desc => lv%base_desc + + end subroutine z_base_onelev_move_alloc + + module subroutine z_base_onelev_allocate_wrk(lv,info,vmold) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv, i + info = psb_success_ + nwv = lv%get_wrksz() + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) +!!$ write(0,*) 'From allocate_wrk :',lv%remap_data%desc_ac_pre_remap%is_asb() + if (info == 0) then + if (lv%remap_data%desc_ac_pre_remap%is_asb()) then + ! + ! Need to fix this, we need two different allocations + ! + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold,& + & desc2=lv%remap_data%desc_ac_pre_remap) + else + call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end if + end if + + end subroutine z_base_onelev_allocate_wrk + + module subroutine z_base_onelev_free_wrk(lv,info) + implicit none + class(amg_z_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv,i + info = psb_success_ + + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if + end subroutine z_base_onelev_free_wrk + + module subroutine z_wrk_alloc(wk,nwv,desc,info,vmold, desc2) + Implicit None + ! Arguments + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + type(psb_desc_type), intent(in), optional :: desc2 + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) +!!$ write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"',& +!!$ & present(desc2),desc%is_valid() + + allocate(wk%wv(nwv),stat=info) + if (present(desc2).and.(desc%is_valid())) then +!!$ write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() + if (desc2%get_local_cols()>desc%get_local_cols()) then + call z_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else + call z_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + else if (present(desc2)) then + call z_inner_do_wrk_alloc(wk,nwv,desc2,vmold=vmold) + else if (desc%is_valid()) then + call z_inner_do_wrk_alloc(wk,nwv,desc,vmold=vmold) + end if + + contains + end subroutine z_wrk_alloc + + module subroutine z_inner_do_wrk_alloc(wk,nwv,desc,vmold) + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + class(psb_z_base_vect_type), intent(in), optional :: vmold + + integer(psb_ipk_) :: i + + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + do i=1,nwv + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + end subroutine z_inner_do_wrk_alloc + + + module subroutine z_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine z_wrk_free + + module subroutine z_wrk_clone(wk,wkout,info) + Implicit None + + ! Arguments + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + class(amg_zmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) + end do + return + + end subroutine z_wrk_clone + + module subroutine z_wrk_move_alloc(wk, b,info) + implicit none + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine z_wrk_move_alloc + + module subroutine z_wrk_cnv(wk,info,vmold) + Implicit None + + ! Arguments + class(amg_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + if (present(vmold)) then + call wk%vtx%cnv(vmold) + call wk%vty%cnv(vmold) + call wk%vx2l%cnv(vmold) + call wk%vy2l%cnv(vmold) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%cnv(vmold) + end do + end if + end if + end subroutine z_wrk_cnv + + module function z_wrk_sizeof(wk) result(val) + implicit none + class(amg_zmlprec_wrk_type), intent(in) :: wk + integer(psb_epk_) :: val + integer :: i + val = 0 + val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%tx) + val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%ty) + val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%x2l) + val = val + (1_psb_epk_ * (2*psb_sizeof_dp)) * psb_size(wk%y2l) + val = val + wk%vtx%sizeof() + val = val + wk%vty%sizeof() + val = val + wk%vx2l%sizeof() + val = val + wk%vy2l%sizeof() + if (allocated(wk%wv)) then + do i=1, size(wk%wv) + val = val + wk%wv(i)%sizeof() + end do + end if + end function z_wrk_sizeof + + module subroutine z_remap_data_clone(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_z_remap_data_type), target, intent(inout) :: rmp + class(amg_z_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call rmp%ac_pre_remap%clone(remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call rmp%desc_ac_pre_remap%clone(remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call psb_safe_ab_cpy(rmp%isrc,remap_out%isrc,info) + call psb_safe_ab_cpy(rmp%nrsrc,remap_out%nrsrc,info) + end subroutine z_remap_data_clone + + module subroutine z_remap_move_alloc(rmp, remap_out, info) + implicit none + ! Arguments + class(amg_z_remap_data_type), target, intent(inout) :: rmp + class(amg_z_remap_data_type), target, intent(inout) :: remap_out + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + + info = psb_success_ + + call psb_move_alloc(rmp%ac_pre_remap,remap_out%ac_pre_remap,info) + if (info == psb_success_) & + & call psb_move_alloc(rmp%desc_ac_pre_remap,remap_out%desc_ac_pre_remap,info) + remap_out%idest = rmp%idest + call move_alloc(rmp%isrc,remap_out%isrc) + call move_alloc(rmp%nrsrc,remap_out%nrsrc) + call move_alloc(rmp%naggr,remap_out%naggr) + end subroutine z_remap_move_alloc + +end submodule amg_z_base_onelev_wrk_handle_impl