diff --git a/.gitignore b/.gitignore index 485fb98d..9d711cb9 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ # header files generated cbind/*.h +util/psb_metis_int.h # Make.inc generated /Make.inc diff --git a/base/comm/internals/psi_covrl_restr.f90 b/base/comm/internals/psi_covrl_restr.f90 index 996e85ad..c0276bfd 100644 --- a/base/comm/internals/psi_covrl_restr.f90 +++ b/base/comm/internals/psi_covrl_restr.f90 @@ -47,7 +47,8 @@ subroutine psi_covrl_restr_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_covrl_restr_vect' @@ -56,8 +57,8 @@ subroutine psi_covrl_restr_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -71,7 +72,7 @@ subroutine psi_covrl_restr_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_restr_vect @@ -89,7 +90,8 @@ subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_covrl_restr_mv' @@ -98,8 +100,8 @@ subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +114,7 @@ subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_restr_multivect diff --git a/base/comm/internals/psi_covrl_restr_a.f90 b/base/comm/internals/psi_covrl_restr_a.f90 index 3c814a81..0ad65753 100644 --- a/base/comm/internals/psi_covrl_restr_a.f90 +++ b/base/comm/internals/psi_covrl_restr_a.f90 @@ -45,7 +45,8 @@ subroutine psi_covrl_restrr1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_covrl_restrr1' @@ -54,8 +55,8 @@ subroutine psi_covrl_restrr1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -72,7 +73,7 @@ subroutine psi_covrl_restrr1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_restrr1 @@ -88,7 +89,8 @@ subroutine psi_covrl_restrr2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_covrl_restrr2' @@ -97,8 +99,8 @@ subroutine psi_covrl_restrr2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -122,7 +124,7 @@ subroutine psi_covrl_restrr2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_restrr2 diff --git a/base/comm/internals/psi_covrl_save.f90 b/base/comm/internals/psi_covrl_save.f90 index c48d2ade..8ee6dc9c 100644 --- a/base/comm/internals/psi_covrl_save.f90 +++ b/base/comm/internals/psi_covrl_save.f90 @@ -47,7 +47,8 @@ subroutine psi_covrl_save_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_covrl_save_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -77,13 +78,11 @@ subroutine psi_covrl_save_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_save_vect - - subroutine psi_covrl_save_multivect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_covrl_save_multivect use psb_realloc_mod @@ -97,7 +96,8 @@ subroutine psi_covrl_save_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -106,8 +106,8 @@ subroutine psi_covrl_save_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -128,7 +128,7 @@ subroutine psi_covrl_save_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_save_multivect diff --git a/base/comm/internals/psi_covrl_save_a.f90 b/base/comm/internals/psi_covrl_save_a.f90 index d017d921..6910a2a4 100644 --- a/base/comm/internals/psi_covrl_save_a.f90 +++ b/base/comm/internals/psi_covrl_save_a.f90 @@ -47,7 +47,8 @@ subroutine psi_covrl_saver1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_covrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_covrl_saver1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -80,7 +81,7 @@ subroutine psi_covrl_saver1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_saver1 @@ -99,7 +100,8 @@ subroutine psi_covrl_saver2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_covrl_saver2' @@ -108,8 +110,8 @@ subroutine psi_covrl_saver2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -133,7 +135,7 @@ subroutine psi_covrl_saver2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_saver2 diff --git a/base/comm/internals/psi_covrl_upd.f90 b/base/comm/internals/psi_covrl_upd.f90 index ce33845e..c829e570 100644 --- a/base/comm/internals/psi_covrl_upd.f90 +++ b/base/comm/internals/psi_covrl_upd.f90 @@ -32,7 +32,7 @@ ! Subroutine: psi_covrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! ! @@ -50,7 +50,8 @@ subroutine psi_covrl_upd_vect(x,desc_a,update,info) ! locals complex(psb_spk_), allocatable :: xs(:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -61,8 +62,8 @@ subroutine psi_covrl_upd_vect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +113,7 @@ subroutine psi_covrl_upd_vect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_upd_vect @@ -131,7 +132,8 @@ subroutine psi_covrl_upd_multivect(x,desc_a,update,info) ! locals complex(psb_spk_), allocatable :: xs(:,:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx, nc integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -142,8 +144,8 @@ subroutine psi_covrl_upd_multivect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -194,7 +196,7 @@ subroutine psi_covrl_upd_multivect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_upd_multivect diff --git a/base/comm/internals/psi_covrl_upd_a.f90 b/base/comm/internals/psi_covrl_upd_a.f90 index 33297731..813cd88b 100644 --- a/base/comm/internals/psi_covrl_upd_a.f90 +++ b/base/comm/internals/psi_covrl_upd_a.f90 @@ -46,7 +46,8 @@ subroutine psi_covrl_updr1(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -56,8 +57,8 @@ subroutine psi_covrl_updr1(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,12 +99,11 @@ subroutine psi_covrl_updr1(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_updr1 - subroutine psi_covrl_updr2(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_covrl_updr2 @@ -115,7 +115,8 @@ subroutine psi_covrl_updr2(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -125,8 +126,8 @@ subroutine psi_covrl_updr2(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -167,7 +168,7 @@ subroutine psi_covrl_updr2(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_covrl_updr2 diff --git a/base/comm/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 index fed8afbf..5f0b8bdc 100644 --- a/base/comm/internals/psi_cswapdata.F90 +++ b/base/comm/internals/psi_cswapdata.F90 @@ -113,7 +113,9 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -121,9 +123,9 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -148,13 +150,13 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswapdata_vect @@ -173,7 +175,7 @@ end subroutine psi_cswapdata_vect ! ! ! -subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_cswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswap_vidx_vect @@ -190,8 +192,10 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y complex(psb_spk_) :: beta complex(psb_spk_), target :: work(:) @@ -199,8 +203,8 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -213,10 +217,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -260,7 +261,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & nesd = idx%v(pnti+nerv+psb_n_elem_send_) rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_complex_swap_tag @@ -413,7 +414,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswap_vidx_vect @@ -450,7 +451,9 @@ subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -458,9 +461,9 @@ subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -485,13 +488,13 @@ subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswapdata_multivect @@ -510,7 +513,7 @@ end subroutine psi_cswapdata_multivect ! ! ! -subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_cswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswap_vidx_multivect @@ -527,8 +530,10 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y complex(psb_spk_) :: beta complex(psb_spk_), target :: work(:) @@ -536,8 +541,8 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -550,10 +555,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -599,7 +601,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_complex_swap_tag @@ -756,7 +758,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswap_vidx_multivect diff --git a/base/comm/internals/psi_cswapdata_a.F90 b/base/comm/internals/psi_cswapdata_a.F90 index 37d019d6..cdc93aba 100644 --- a/base/comm/internals/psi_cswapdata_a.F90 +++ b/base/comm/internals/psi_cswapdata_a.F90 @@ -106,7 +106,9 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -141,18 +143,18 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswapdatam -subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & +subroutine psi_cswapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswapidxm @@ -167,15 +169,18 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:,:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -192,10 +197,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -235,7 +237,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -314,14 +316,14 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -348,7 +350,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_complex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& @@ -433,7 +435,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -450,7 +452,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -498,7 +500,7 @@ subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswapidxm @@ -579,7 +581,9 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -587,9 +591,9 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -614,13 +618,13 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswapdatav @@ -636,7 +640,7 @@ end subroutine psi_cswapdatav ! ! ! -subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_cswapidxv(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswapidxv @@ -651,15 +655,17 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -676,10 +682,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -719,7 +722,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -799,14 +802,14 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -833,7 +836,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_complex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& @@ -917,7 +920,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -933,7 +936,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -980,7 +983,7 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswapidxv diff --git a/base/comm/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 index 152cb045..aefb6b01 100644 --- a/base/comm/internals/psi_cswaptran.F90 +++ b/base/comm/internals/psi_cswaptran.F90 @@ -115,7 +115,9 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -123,9 +125,9 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -150,19 +152,17 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswaptran_vect - - ! ! ! Subroutine: psi_ctran_vidx_vect @@ -176,7 +176,7 @@ end subroutine psi_cswaptran_vect ! ! ! -subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ctran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctran_vidx_vect @@ -193,7 +193,9 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y complex(psb_spk_) :: beta @@ -202,8 +204,8 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -216,10 +218,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -266,7 +265,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt call mpi_irecv(y%combuf(snd_pt),nesd,& @@ -422,7 +421,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -463,7 +462,9 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -471,9 +472,9 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -498,13 +499,13 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswaptran_multivect @@ -523,7 +524,7 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! ! ! -subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ctran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctran_vidx_multivect @@ -540,7 +541,9 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y complex(psb_spk_) :: beta @@ -549,8 +552,8 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -563,10 +566,7 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -613,7 +613,7 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt call mpi_irecv(y%combuf(snd_pt),n*nesd,& @@ -773,7 +773,7 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/internals/psi_cswaptran_a.F90 b/base/comm/internals/psi_cswaptran_a.F90 index f43e3be3..55a4b747 100644 --- a/base/comm/internals/psi_cswaptran_a.F90 +++ b/base/comm/internals/psi_cswaptran_a.F90 @@ -110,7 +110,9 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -118,10 +120,10 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -146,18 +148,18 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswaptranm -subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& +subroutine psi_ctranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctranidxm @@ -172,15 +174,17 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:,:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -197,10 +201,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -240,7 +241,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -324,14 +325,14 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -358,7 +359,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_complex_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& @@ -443,7 +444,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -460,7 +461,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -508,7 +509,7 @@ subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_ctranidxm @@ -592,7 +593,9 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -600,9 +603,9 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -627,13 +630,13 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_cswaptranv @@ -649,7 +652,7 @@ end subroutine psi_cswaptranv ! ! ! -subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ctranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ctranidxv @@ -664,15 +667,22 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -689,10 +699,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -732,7 +739,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -817,14 +824,14 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -850,7 +857,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_complex_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& @@ -933,7 +940,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -949,7 +956,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -996,7 +1003,7 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_ctranidxv diff --git a/base/comm/internals/psi_dovrl_restr.f90 b/base/comm/internals/psi_dovrl_restr.f90 index 1d6695cc..22a77328 100644 --- a/base/comm/internals/psi_dovrl_restr.f90 +++ b/base/comm/internals/psi_dovrl_restr.f90 @@ -47,7 +47,8 @@ subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_restr_vect' @@ -56,8 +57,8 @@ subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -71,7 +72,7 @@ subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_restr_vect @@ -89,7 +90,8 @@ subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_restr_mv' @@ -98,8 +100,8 @@ subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +114,7 @@ subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_restr_multivect diff --git a/base/comm/internals/psi_dovrl_restr_a.f90 b/base/comm/internals/psi_dovrl_restr_a.f90 index df47403b..768f6b26 100644 --- a/base/comm/internals/psi_dovrl_restr_a.f90 +++ b/base/comm/internals/psi_dovrl_restr_a.f90 @@ -45,7 +45,8 @@ subroutine psi_dovrl_restrr1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_restrr1' @@ -54,8 +55,8 @@ subroutine psi_dovrl_restrr1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -72,7 +73,7 @@ subroutine psi_dovrl_restrr1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_restrr1 @@ -88,7 +89,8 @@ subroutine psi_dovrl_restrr2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_restrr2' @@ -97,8 +99,8 @@ subroutine psi_dovrl_restrr2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -122,7 +124,7 @@ subroutine psi_dovrl_restrr2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_restrr2 diff --git a/base/comm/internals/psi_dovrl_save.f90 b/base/comm/internals/psi_dovrl_save.f90 index 0689ee1b..38a83d2d 100644 --- a/base/comm/internals/psi_dovrl_save.f90 +++ b/base/comm/internals/psi_dovrl_save.f90 @@ -47,7 +47,8 @@ subroutine psi_dovrl_save_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_dovrl_save_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -77,13 +78,11 @@ subroutine psi_dovrl_save_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_save_vect - - subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_dovrl_save_multivect use psb_realloc_mod @@ -97,7 +96,8 @@ subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -106,8 +106,8 @@ subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -128,7 +128,7 @@ subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_save_multivect diff --git a/base/comm/internals/psi_dovrl_save_a.f90 b/base/comm/internals/psi_dovrl_save_a.f90 index fcc19e08..25c821b8 100644 --- a/base/comm/internals/psi_dovrl_save_a.f90 +++ b/base/comm/internals/psi_dovrl_save_a.f90 @@ -47,7 +47,8 @@ subroutine psi_dovrl_saver1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_dovrl_saver1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -80,7 +81,7 @@ subroutine psi_dovrl_saver1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_saver1 @@ -99,7 +100,8 @@ subroutine psi_dovrl_saver2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_saver2' @@ -108,8 +110,8 @@ subroutine psi_dovrl_saver2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -133,7 +135,7 @@ subroutine psi_dovrl_saver2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_saver2 diff --git a/base/comm/internals/psi_dovrl_upd.f90 b/base/comm/internals/psi_dovrl_upd.f90 index efbb2495..261971ba 100644 --- a/base/comm/internals/psi_dovrl_upd.f90 +++ b/base/comm/internals/psi_dovrl_upd.f90 @@ -32,7 +32,7 @@ ! Subroutine: psi_dovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! ! @@ -50,7 +50,8 @@ subroutine psi_dovrl_upd_vect(x,desc_a,update,info) ! locals real(psb_dpk_), allocatable :: xs(:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -61,8 +62,8 @@ subroutine psi_dovrl_upd_vect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +113,7 @@ subroutine psi_dovrl_upd_vect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_upd_vect @@ -131,7 +132,8 @@ subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) ! locals real(psb_dpk_), allocatable :: xs(:,:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx, nc integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -142,8 +144,8 @@ subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -194,7 +196,7 @@ subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_upd_multivect diff --git a/base/comm/internals/psi_dovrl_upd_a.f90 b/base/comm/internals/psi_dovrl_upd_a.f90 index 8ad3db6b..9678d3e3 100644 --- a/base/comm/internals/psi_dovrl_upd_a.f90 +++ b/base/comm/internals/psi_dovrl_upd_a.f90 @@ -46,7 +46,8 @@ subroutine psi_dovrl_updr1(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -56,8 +57,8 @@ subroutine psi_dovrl_updr1(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,12 +99,11 @@ subroutine psi_dovrl_updr1(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_updr1 - subroutine psi_dovrl_updr2(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_dovrl_updr2 @@ -115,7 +115,8 @@ subroutine psi_dovrl_updr2(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -125,8 +126,8 @@ subroutine psi_dovrl_updr2(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -167,7 +168,7 @@ subroutine psi_dovrl_updr2(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dovrl_updr2 diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index a59b9b79..fe529706 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -113,7 +113,9 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -121,9 +123,9 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -148,13 +150,13 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswapdata_vect @@ -173,7 +175,7 @@ end subroutine psi_dswapdata_vect ! ! ! -subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_dswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswap_vidx_vect @@ -190,8 +192,10 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y real(psb_dpk_) :: beta real(psb_dpk_), target :: work(:) @@ -199,8 +203,8 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -213,10 +217,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -260,7 +261,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & nesd = idx%v(pnti+nerv+psb_n_elem_send_) rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_double_swap_tag @@ -413,7 +414,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswap_vidx_vect @@ -450,7 +451,9 @@ subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -458,9 +461,9 @@ subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -485,13 +488,13 @@ subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswapdata_multivect @@ -510,7 +513,7 @@ end subroutine psi_dswapdata_multivect ! ! ! -subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswap_vidx_multivect @@ -527,8 +530,10 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y real(psb_dpk_) :: beta real(psb_dpk_), target :: work(:) @@ -536,8 +541,8 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -550,10 +555,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -599,7 +601,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_double_swap_tag @@ -756,7 +758,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswap_vidx_multivect diff --git a/base/comm/internals/psi_dswapdata_a.F90 b/base/comm/internals/psi_dswapdata_a.F90 index 7400548a..cd514065 100644 --- a/base/comm/internals/psi_dswapdata_a.F90 +++ b/base/comm/internals/psi_dswapdata_a.F90 @@ -106,7 +106,9 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -141,18 +143,18 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswapdatam -subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & +subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswapidxm @@ -167,15 +169,18 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:,:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -192,10 +197,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -235,7 +237,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -314,14 +316,14 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -348,7 +350,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& @@ -433,7 +435,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -450,7 +452,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -498,7 +500,7 @@ subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswapidxm @@ -579,7 +581,9 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -587,9 +591,9 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -614,13 +618,13 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswapdatav @@ -636,7 +640,7 @@ end subroutine psi_dswapdatav ! ! ! -subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_dswapidxv(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswapidxv @@ -651,15 +655,17 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -676,10 +682,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -719,7 +722,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -799,14 +802,14 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -833,7 +836,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& @@ -917,7 +920,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -933,7 +936,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -980,7 +983,7 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswapidxv diff --git a/base/comm/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 index 1feee33c..df98e1ae 100644 --- a/base/comm/internals/psi_dswaptran.F90 +++ b/base/comm/internals/psi_dswaptran.F90 @@ -115,7 +115,9 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -123,9 +125,9 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -150,19 +152,17 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswaptran_vect - - ! ! ! Subroutine: psi_dtran_vidx_vect @@ -176,7 +176,7 @@ end subroutine psi_dswaptran_vect ! ! ! -subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_dtran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtran_vidx_vect @@ -193,7 +193,9 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y real(psb_dpk_) :: beta @@ -202,8 +204,8 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -216,10 +218,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -266,7 +265,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt call mpi_irecv(y%combuf(snd_pt),nesd,& @@ -422,7 +421,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -463,7 +462,9 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -471,9 +472,9 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -498,13 +499,13 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswaptran_multivect @@ -523,7 +524,7 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! ! ! -subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_dtran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtran_vidx_multivect @@ -540,7 +541,9 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y real(psb_dpk_) :: beta @@ -549,8 +552,8 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -563,10 +566,7 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -613,7 +613,7 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt call mpi_irecv(y%combuf(snd_pt),n*nesd,& @@ -773,7 +773,7 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/internals/psi_dswaptran_a.F90 b/base/comm/internals/psi_dswaptran_a.F90 index cce55b4d..8c5b63d4 100644 --- a/base/comm/internals/psi_dswaptran_a.F90 +++ b/base/comm/internals/psi_dswaptran_a.F90 @@ -110,7 +110,9 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -118,10 +120,10 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -146,18 +148,18 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswaptranm -subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& +subroutine psi_dtranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtranidxm @@ -172,15 +174,22 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:,:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -197,10 +206,7 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -240,7 +246,7 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -324,14 +330,14 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -358,7 +364,7 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& @@ -443,7 +449,7 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -460,7 +466,7 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -508,7 +514,7 @@ subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dtranidxm @@ -592,7 +598,9 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -600,9 +608,9 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -627,13 +635,13 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dswaptranv @@ -649,7 +657,7 @@ end subroutine psi_dswaptranv ! ! ! -subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_dtranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dtranidxv @@ -664,15 +672,22 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta real(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -689,10 +704,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -732,7 +744,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -817,14 +829,14 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -850,7 +862,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& @@ -933,7 +945,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -949,7 +961,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -996,7 +1008,7 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_dtranidxv diff --git a/base/comm/internals/psi_eovrl_restr_a.f90 b/base/comm/internals/psi_eovrl_restr_a.f90 index 3dbb2ac4..cfd08936 100644 --- a/base/comm/internals/psi_eovrl_restr_a.f90 +++ b/base/comm/internals/psi_eovrl_restr_a.f90 @@ -45,7 +45,8 @@ subroutine psi_eovrl_restrr1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_eovrl_restrr1' @@ -54,8 +55,8 @@ subroutine psi_eovrl_restrr1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -72,7 +73,7 @@ subroutine psi_eovrl_restrr1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eovrl_restrr1 @@ -88,7 +89,8 @@ subroutine psi_eovrl_restrr2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_eovrl_restrr2' @@ -97,8 +99,8 @@ subroutine psi_eovrl_restrr2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -122,7 +124,7 @@ subroutine psi_eovrl_restrr2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eovrl_restrr2 diff --git a/base/comm/internals/psi_eovrl_save_a.f90 b/base/comm/internals/psi_eovrl_save_a.f90 index 4f0b7d30..adcb981a 100644 --- a/base/comm/internals/psi_eovrl_save_a.f90 +++ b/base/comm/internals/psi_eovrl_save_a.f90 @@ -47,7 +47,8 @@ subroutine psi_eovrl_saver1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_eovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_eovrl_saver1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -80,7 +81,7 @@ subroutine psi_eovrl_saver1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eovrl_saver1 @@ -99,7 +100,8 @@ subroutine psi_eovrl_saver2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_eovrl_saver2' @@ -108,8 +110,8 @@ subroutine psi_eovrl_saver2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -133,7 +135,7 @@ subroutine psi_eovrl_saver2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eovrl_saver2 diff --git a/base/comm/internals/psi_eovrl_upd_a.f90 b/base/comm/internals/psi_eovrl_upd_a.f90 index e8e40738..c1427547 100644 --- a/base/comm/internals/psi_eovrl_upd_a.f90 +++ b/base/comm/internals/psi_eovrl_upd_a.f90 @@ -46,7 +46,8 @@ subroutine psi_eovrl_updr1(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -56,8 +57,8 @@ subroutine psi_eovrl_updr1(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,12 +99,11 @@ subroutine psi_eovrl_updr1(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eovrl_updr1 - subroutine psi_eovrl_updr2(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_eovrl_updr2 @@ -115,7 +115,8 @@ subroutine psi_eovrl_updr2(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -125,8 +126,8 @@ subroutine psi_eovrl_updr2(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -167,7 +168,7 @@ subroutine psi_eovrl_updr2(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eovrl_updr2 diff --git a/base/comm/internals/psi_eswapdata_a.F90 b/base/comm/internals/psi_eswapdata_a.F90 index aa0cda65..bc477224 100644 --- a/base/comm/internals/psi_eswapdata_a.F90 +++ b/base/comm/internals/psi_eswapdata_a.F90 @@ -106,7 +106,9 @@ subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -141,18 +143,18 @@ subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eswapdatam -subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & +subroutine psi_eswapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_eswapidxm @@ -167,15 +169,18 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:,:), beta integer(psb_epk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -192,10 +197,7 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -235,7 +237,7 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -314,14 +316,14 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -348,7 +350,7 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_int8_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& @@ -433,7 +435,7 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -450,7 +452,7 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -498,7 +500,7 @@ subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eswapidxm @@ -579,7 +581,9 @@ subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -587,9 +591,9 @@ subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -614,13 +618,13 @@ subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eswapdatav @@ -636,7 +640,7 @@ end subroutine psi_eswapdatav ! ! ! -subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_eswapidxv(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_eswapidxv @@ -651,15 +655,17 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta integer(psb_epk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -676,10 +682,7 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -719,7 +722,7 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -799,14 +802,14 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -833,7 +836,7 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_int8_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& @@ -917,7 +920,7 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -933,7 +936,7 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -980,7 +983,7 @@ subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eswapidxv diff --git a/base/comm/internals/psi_eswaptran_a.F90 b/base/comm/internals/psi_eswaptran_a.F90 index 0df27a5d..d11b2ea1 100644 --- a/base/comm/internals/psi_eswaptran_a.F90 +++ b/base/comm/internals/psi_eswaptran_a.F90 @@ -110,7 +110,9 @@ subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -118,10 +120,10 @@ subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -146,18 +148,18 @@ subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eswaptranm -subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& +subroutine psi_etranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_etranidxm @@ -172,15 +174,17 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:,:), beta integer(psb_epk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -197,10 +201,7 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -240,7 +241,7 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -324,14 +325,14 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -358,7 +359,7 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_int8_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& @@ -443,7 +444,7 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -460,7 +461,7 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -508,7 +509,7 @@ subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_etranidxm @@ -592,7 +593,9 @@ subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -600,9 +603,9 @@ subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -627,13 +630,13 @@ subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_eswaptranv @@ -649,7 +652,7 @@ end subroutine psi_eswaptranv ! ! ! -subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_etranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_etranidxv @@ -664,15 +667,22 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta integer(psb_epk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -689,10 +699,7 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -732,7 +739,7 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -817,14 +824,14 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -850,7 +857,7 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_int8_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& @@ -933,7 +940,7 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -949,7 +956,7 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -996,7 +1003,7 @@ subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_etranidxv diff --git a/base/comm/internals/psi_i2ovrl_restr_a.f90 b/base/comm/internals/psi_i2ovrl_restr_a.f90 index 36bc2566..acb6b25d 100644 --- a/base/comm/internals/psi_i2ovrl_restr_a.f90 +++ b/base/comm/internals/psi_i2ovrl_restr_a.f90 @@ -45,7 +45,8 @@ subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_i2ovrl_restrr1' @@ -54,8 +55,8 @@ subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -72,7 +73,7 @@ subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2ovrl_restrr1 @@ -88,7 +89,8 @@ subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_i2ovrl_restrr2' @@ -97,8 +99,8 @@ subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -122,7 +124,7 @@ subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2ovrl_restrr2 diff --git a/base/comm/internals/psi_i2ovrl_save_a.f90 b/base/comm/internals/psi_i2ovrl_save_a.f90 index 55e9ae89..dc0b3f54 100644 --- a/base/comm/internals/psi_i2ovrl_save_a.f90 +++ b/base/comm/internals/psi_i2ovrl_save_a.f90 @@ -47,7 +47,8 @@ subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_i2ovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -80,7 +81,7 @@ subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2ovrl_saver1 @@ -99,7 +100,8 @@ subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_i2ovrl_saver2' @@ -108,8 +110,8 @@ subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -133,7 +135,7 @@ subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2ovrl_saver2 diff --git a/base/comm/internals/psi_i2ovrl_upd_a.f90 b/base/comm/internals/psi_i2ovrl_upd_a.f90 index c41803ef..973ffa8e 100644 --- a/base/comm/internals/psi_i2ovrl_upd_a.f90 +++ b/base/comm/internals/psi_i2ovrl_upd_a.f90 @@ -46,7 +46,8 @@ subroutine psi_i2ovrl_updr1(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -56,8 +57,8 @@ subroutine psi_i2ovrl_updr1(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,12 +99,11 @@ subroutine psi_i2ovrl_updr1(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2ovrl_updr1 - subroutine psi_i2ovrl_updr2(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_i2ovrl_updr2 @@ -115,7 +115,8 @@ subroutine psi_i2ovrl_updr2(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -125,8 +126,8 @@ subroutine psi_i2ovrl_updr2(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -167,7 +168,7 @@ subroutine psi_i2ovrl_updr2(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2ovrl_updr2 diff --git a/base/comm/internals/psi_i2swapdata_a.F90 b/base/comm/internals/psi_i2swapdata_a.F90 index 0140504d..e382c4b6 100644 --- a/base/comm/internals/psi_i2swapdata_a.F90 +++ b/base/comm/internals/psi_i2swapdata_a.F90 @@ -106,7 +106,9 @@ subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -141,18 +143,18 @@ subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2swapdatam -subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & +subroutine psi_i2swapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_i2swapidxm @@ -167,15 +169,18 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:,:), beta integer(psb_i2pk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -192,10 +197,7 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -235,7 +237,7 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -314,14 +316,14 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -348,7 +350,7 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_int2_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& @@ -433,7 +435,7 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -450,7 +452,7 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -498,7 +500,7 @@ subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2swapidxm @@ -579,7 +581,9 @@ subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -587,9 +591,9 @@ subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -614,13 +618,13 @@ subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2swapdatav @@ -636,7 +640,7 @@ end subroutine psi_i2swapdatav ! ! ! -subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_i2swapidxv(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_i2swapidxv @@ -651,15 +655,17 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta integer(psb_i2pk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -676,10 +682,7 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -719,7 +722,7 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -799,14 +802,14 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -833,7 +836,7 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_int2_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& @@ -917,7 +920,7 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -933,7 +936,7 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -980,7 +983,7 @@ subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2swapidxv diff --git a/base/comm/internals/psi_i2swaptran_a.F90 b/base/comm/internals/psi_i2swaptran_a.F90 index 10531927..a334a5a8 100644 --- a/base/comm/internals/psi_i2swaptran_a.F90 +++ b/base/comm/internals/psi_i2swaptran_a.F90 @@ -110,7 +110,9 @@ subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -118,10 +120,10 @@ subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -146,18 +148,18 @@ subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2swaptranm -subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& +subroutine psi_i2tranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_i2tranidxm @@ -172,15 +174,17 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:,:), beta integer(psb_i2pk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -197,10 +201,7 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -240,7 +241,7 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -324,14 +325,14 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -358,7 +359,7 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_int2_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& @@ -443,7 +444,7 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -460,7 +461,7 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -508,7 +509,7 @@ subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2tranidxm @@ -592,7 +593,9 @@ subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -600,9 +603,9 @@ subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -627,13 +630,13 @@ subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2swaptranv @@ -649,7 +652,7 @@ end subroutine psi_i2swaptranv ! ! ! -subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_i2tranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_i2tranidxv @@ -664,15 +667,22 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta integer(psb_i2pk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -689,10 +699,7 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -732,7 +739,7 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -817,14 +824,14 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -850,7 +857,7 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_int2_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& @@ -933,7 +940,7 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -949,7 +956,7 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -996,7 +1003,7 @@ subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_i2tranidxv diff --git a/base/comm/internals/psi_iovrl_restr.f90 b/base/comm/internals/psi_iovrl_restr.f90 index b0efa2ee..4059f508 100644 --- a/base/comm/internals/psi_iovrl_restr.f90 +++ b/base/comm/internals/psi_iovrl_restr.f90 @@ -47,7 +47,8 @@ subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_iovrl_restr_vect' @@ -56,8 +57,8 @@ subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -71,7 +72,7 @@ subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iovrl_restr_vect @@ -89,7 +90,8 @@ subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_iovrl_restr_mv' @@ -98,8 +100,8 @@ subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +114,7 @@ subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iovrl_restr_multivect diff --git a/base/comm/internals/psi_iovrl_save.f90 b/base/comm/internals/psi_iovrl_save.f90 index cc7619f9..0a9b13fd 100644 --- a/base/comm/internals/psi_iovrl_save.f90 +++ b/base/comm/internals/psi_iovrl_save.f90 @@ -47,7 +47,8 @@ subroutine psi_iovrl_save_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_iovrl_save_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -77,13 +78,11 @@ subroutine psi_iovrl_save_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iovrl_save_vect - - subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_iovrl_save_multivect use psb_realloc_mod @@ -97,7 +96,8 @@ subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -106,8 +106,8 @@ subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -128,7 +128,7 @@ subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iovrl_save_multivect diff --git a/base/comm/internals/psi_iovrl_upd.f90 b/base/comm/internals/psi_iovrl_upd.f90 index 988bf006..4eefe131 100644 --- a/base/comm/internals/psi_iovrl_upd.f90 +++ b/base/comm/internals/psi_iovrl_upd.f90 @@ -32,7 +32,7 @@ ! Subroutine: psi_iovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! ! @@ -50,7 +50,8 @@ subroutine psi_iovrl_upd_vect(x,desc_a,update,info) ! locals integer(psb_ipk_), allocatable :: xs(:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -61,8 +62,8 @@ subroutine psi_iovrl_upd_vect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +113,7 @@ subroutine psi_iovrl_upd_vect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iovrl_upd_vect @@ -131,7 +132,8 @@ subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) ! locals integer(psb_ipk_), allocatable :: xs(:,:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx, nc integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -142,8 +144,8 @@ subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -194,7 +196,7 @@ subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iovrl_upd_multivect diff --git a/base/comm/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 index d05ab8ac..ff4bd074 100644 --- a/base/comm/internals/psi_iswapdata.F90 +++ b/base/comm/internals/psi_iswapdata.F90 @@ -113,7 +113,9 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -121,9 +123,9 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -148,13 +150,13 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iswapdata_vect @@ -173,7 +175,7 @@ end subroutine psi_iswapdata_vect ! ! ! -subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_iswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_iswap_vidx_vect @@ -190,8 +192,10 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type) :: y integer(psb_ipk_) :: beta integer(psb_ipk_), target :: work(:) @@ -199,8 +203,8 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -213,10 +217,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -260,7 +261,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & nesd = idx%v(pnti+nerv+psb_n_elem_send_) rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_int_swap_tag @@ -413,7 +414,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iswap_vidx_vect @@ -450,7 +451,9 @@ subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -458,9 +461,9 @@ subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -485,13 +488,13 @@ subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iswapdata_multivect @@ -510,7 +513,7 @@ end subroutine psi_iswapdata_multivect ! ! ! -subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_iswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_iswap_vidx_multivect @@ -527,8 +530,10 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y integer(psb_ipk_) :: beta integer(psb_ipk_), target :: work(:) @@ -536,8 +541,8 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -550,10 +555,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -599,7 +601,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_int_swap_tag @@ -756,7 +758,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iswap_vidx_multivect diff --git a/base/comm/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 index e5719735..75a0a185 100644 --- a/base/comm/internals/psi_iswaptran.F90 +++ b/base/comm/internals/psi_iswaptran.F90 @@ -115,7 +115,9 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -123,9 +125,9 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -150,19 +152,17 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iswaptran_vect - - ! ! ! Subroutine: psi_itran_vidx_vect @@ -176,7 +176,7 @@ end subroutine psi_iswaptran_vect ! ! ! -subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_itran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_itran_vidx_vect @@ -193,7 +193,9 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type) :: y integer(psb_ipk_) :: beta @@ -202,8 +204,8 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -216,10 +218,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -266,7 +265,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt call mpi_irecv(y%combuf(snd_pt),nesd,& @@ -422,7 +421,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -463,7 +462,9 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -471,9 +472,9 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -498,13 +499,13 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_iswaptran_multivect @@ -523,7 +524,7 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! ! ! -subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_itran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_itran_vidx_multivect @@ -540,7 +541,9 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y integer(psb_ipk_) :: beta @@ -549,8 +552,8 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -563,10 +566,7 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -613,7 +613,7 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt call mpi_irecv(y%combuf(snd_pt),n*nesd,& @@ -773,7 +773,7 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/internals/psi_lovrl_restr.f90 b/base/comm/internals/psi_lovrl_restr.f90 index dc33bbb1..71871e70 100644 --- a/base/comm/internals/psi_lovrl_restr.f90 +++ b/base/comm/internals/psi_lovrl_restr.f90 @@ -47,7 +47,8 @@ subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_lovrl_restr_vect' @@ -56,8 +57,8 @@ subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -71,7 +72,7 @@ subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lovrl_restr_vect @@ -89,7 +90,8 @@ subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_lovrl_restr_mv' @@ -98,8 +100,8 @@ subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +114,7 @@ subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lovrl_restr_multivect diff --git a/base/comm/internals/psi_lovrl_save.f90 b/base/comm/internals/psi_lovrl_save.f90 index 496eec90..29d3b0ad 100644 --- a/base/comm/internals/psi_lovrl_save.f90 +++ b/base/comm/internals/psi_lovrl_save.f90 @@ -47,7 +47,8 @@ subroutine psi_lovrl_save_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_lovrl_save_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -77,13 +78,11 @@ subroutine psi_lovrl_save_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lovrl_save_vect - - subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_lovrl_save_multivect use psb_realloc_mod @@ -97,7 +96,8 @@ subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -106,8 +106,8 @@ subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -128,7 +128,7 @@ subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lovrl_save_multivect diff --git a/base/comm/internals/psi_lovrl_upd.f90 b/base/comm/internals/psi_lovrl_upd.f90 index d20d80cc..d8b4bb5a 100644 --- a/base/comm/internals/psi_lovrl_upd.f90 +++ b/base/comm/internals/psi_lovrl_upd.f90 @@ -32,7 +32,7 @@ ! Subroutine: psi_lovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! ! @@ -50,7 +50,8 @@ subroutine psi_lovrl_upd_vect(x,desc_a,update,info) ! locals integer(psb_lpk_), allocatable :: xs(:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -61,8 +62,8 @@ subroutine psi_lovrl_upd_vect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +113,7 @@ subroutine psi_lovrl_upd_vect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lovrl_upd_vect @@ -131,7 +132,8 @@ subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) ! locals integer(psb_lpk_), allocatable :: xs(:,:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx, nc integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -142,8 +144,8 @@ subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -194,7 +196,7 @@ subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lovrl_upd_multivect diff --git a/base/comm/internals/psi_lswapdata.F90 b/base/comm/internals/psi_lswapdata.F90 index 939f9596..9201ebfa 100644 --- a/base/comm/internals/psi_lswapdata.F90 +++ b/base/comm/internals/psi_lswapdata.F90 @@ -113,7 +113,9 @@ subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -121,9 +123,9 @@ subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -148,13 +150,13 @@ subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lswapdata_vect @@ -173,7 +175,7 @@ end subroutine psi_lswapdata_vect ! ! ! -subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_lswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_lswap_vidx_vect @@ -190,8 +192,10 @@ subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type) :: y integer(psb_lpk_) :: beta integer(psb_lpk_), target :: work(:) @@ -199,8 +203,8 @@ subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -213,10 +217,7 @@ subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -260,7 +261,7 @@ subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & nesd = idx%v(pnti+nerv+psb_n_elem_send_) rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_long_swap_tag @@ -413,7 +414,7 @@ subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lswap_vidx_vect @@ -450,7 +451,9 @@ subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -458,9 +461,9 @@ subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -485,13 +488,13 @@ subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lswapdata_multivect @@ -510,7 +513,7 @@ end subroutine psi_lswapdata_multivect ! ! ! -subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_lswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_lswap_vidx_multivect @@ -527,8 +530,10 @@ subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_l_base_multivect_type) :: y integer(psb_lpk_) :: beta integer(psb_lpk_), target :: work(:) @@ -536,8 +541,8 @@ subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -550,10 +555,7 @@ subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -599,7 +601,7 @@ subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_long_swap_tag @@ -756,7 +758,7 @@ subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lswap_vidx_multivect diff --git a/base/comm/internals/psi_lswaptran.F90 b/base/comm/internals/psi_lswaptran.F90 index ccc1b6e3..b2b9536c 100644 --- a/base/comm/internals/psi_lswaptran.F90 +++ b/base/comm/internals/psi_lswaptran.F90 @@ -115,7 +115,9 @@ subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -123,9 +125,9 @@ subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -150,19 +152,17 @@ subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lswaptran_vect - - ! ! ! Subroutine: psi_ltran_vidx_vect @@ -176,7 +176,7 @@ end subroutine psi_lswaptran_vect ! ! ! -subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ltran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ltran_vidx_vect @@ -193,7 +193,9 @@ subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type) :: y integer(psb_lpk_) :: beta @@ -202,8 +204,8 @@ subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -216,10 +218,7 @@ subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -266,7 +265,7 @@ subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt call mpi_irecv(y%combuf(snd_pt),nesd,& @@ -422,7 +421,7 @@ subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -463,7 +462,9 @@ subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -471,9 +472,9 @@ subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -498,13 +499,13 @@ subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_lswaptran_multivect @@ -523,7 +524,7 @@ subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! ! ! -subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ltran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ltran_vidx_multivect @@ -540,7 +541,9 @@ subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_multivect_type) :: y integer(psb_lpk_) :: beta @@ -549,8 +552,8 @@ subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -563,10 +566,7 @@ subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -613,7 +613,7 @@ subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt call mpi_irecv(y%combuf(snd_pt),n*nesd,& @@ -773,7 +773,7 @@ subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/internals/psi_movrl_restr_a.f90 b/base/comm/internals/psi_movrl_restr_a.f90 index 92e06793..d884ad63 100644 --- a/base/comm/internals/psi_movrl_restr_a.f90 +++ b/base/comm/internals/psi_movrl_restr_a.f90 @@ -45,7 +45,8 @@ subroutine psi_movrl_restrr1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_movrl_restrr1' @@ -54,8 +55,8 @@ subroutine psi_movrl_restrr1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -72,7 +73,7 @@ subroutine psi_movrl_restrr1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_movrl_restrr1 @@ -88,7 +89,8 @@ subroutine psi_movrl_restrr2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_movrl_restrr2' @@ -97,8 +99,8 @@ subroutine psi_movrl_restrr2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -122,7 +124,7 @@ subroutine psi_movrl_restrr2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_movrl_restrr2 diff --git a/base/comm/internals/psi_movrl_save_a.f90 b/base/comm/internals/psi_movrl_save_a.f90 index fbc021cf..398ea24a 100644 --- a/base/comm/internals/psi_movrl_save_a.f90 +++ b/base/comm/internals/psi_movrl_save_a.f90 @@ -47,7 +47,8 @@ subroutine psi_movrl_saver1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_movrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_movrl_saver1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -80,7 +81,7 @@ subroutine psi_movrl_saver1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_movrl_saver1 @@ -99,7 +100,8 @@ subroutine psi_movrl_saver2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_movrl_saver2' @@ -108,8 +110,8 @@ subroutine psi_movrl_saver2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -133,7 +135,7 @@ subroutine psi_movrl_saver2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_movrl_saver2 diff --git a/base/comm/internals/psi_movrl_upd_a.f90 b/base/comm/internals/psi_movrl_upd_a.f90 index 03670659..c4ffa64f 100644 --- a/base/comm/internals/psi_movrl_upd_a.f90 +++ b/base/comm/internals/psi_movrl_upd_a.f90 @@ -46,7 +46,8 @@ subroutine psi_movrl_updr1(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -56,8 +57,8 @@ subroutine psi_movrl_updr1(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,12 +99,11 @@ subroutine psi_movrl_updr1(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_movrl_updr1 - subroutine psi_movrl_updr2(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_movrl_updr2 @@ -115,7 +115,8 @@ subroutine psi_movrl_updr2(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -125,8 +126,8 @@ subroutine psi_movrl_updr2(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -167,7 +168,7 @@ subroutine psi_movrl_updr2(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_movrl_updr2 diff --git a/base/comm/internals/psi_mswapdata_a.F90 b/base/comm/internals/psi_mswapdata_a.F90 index 32b8a64e..69f64cc6 100644 --- a/base/comm/internals/psi_mswapdata_a.F90 +++ b/base/comm/internals/psi_mswapdata_a.F90 @@ -106,7 +106,9 @@ subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -141,18 +143,18 @@ subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mswapdatam -subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & +subroutine psi_mswapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_mswapidxm @@ -167,15 +169,18 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:,:), beta integer(psb_mpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -192,10 +197,7 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -235,7 +237,7 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -314,14 +316,14 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -348,7 +350,7 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_int4_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& @@ -433,7 +435,7 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -450,7 +452,7 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -498,7 +500,7 @@ subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mswapidxm @@ -579,7 +581,9 @@ subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -587,9 +591,9 @@ subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -614,13 +618,13 @@ subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mswapdatav @@ -636,7 +640,7 @@ end subroutine psi_mswapdatav ! ! ! -subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_mswapidxv(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_mswapidxv @@ -651,15 +655,17 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta integer(psb_mpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -676,10 +682,7 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -719,7 +722,7 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -799,14 +802,14 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -833,7 +836,7 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_int4_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& @@ -917,7 +920,7 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -933,7 +936,7 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -980,7 +983,7 @@ subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mswapidxv diff --git a/base/comm/internals/psi_mswaptran_a.F90 b/base/comm/internals/psi_mswaptran_a.F90 index 7b94d480..0aae2c98 100644 --- a/base/comm/internals/psi_mswaptran_a.F90 +++ b/base/comm/internals/psi_mswaptran_a.F90 @@ -110,7 +110,9 @@ subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -118,10 +120,10 @@ subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -146,18 +148,18 @@ subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mswaptranm -subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& +subroutine psi_mtranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_mtranidxm @@ -172,15 +174,17 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:,:), beta integer(psb_mpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -197,10 +201,7 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -240,7 +241,7 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -324,14 +325,14 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -358,7 +359,7 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_int4_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& @@ -443,7 +444,7 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -460,7 +461,7 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -508,7 +509,7 @@ subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mtranidxm @@ -592,7 +593,9 @@ subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -600,9 +603,9 @@ subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -627,13 +630,13 @@ subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mswaptranv @@ -649,7 +652,7 @@ end subroutine psi_mswaptranv ! ! ! -subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_mtranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_mtranidxv @@ -664,15 +667,22 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta integer(psb_mpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -689,10 +699,7 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -732,7 +739,7 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -817,14 +824,14 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -850,7 +857,7 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_int4_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& @@ -933,7 +940,7 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -949,7 +956,7 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -996,7 +1003,7 @@ subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_mtranidxv diff --git a/base/comm/internals/psi_sovrl_restr.f90 b/base/comm/internals/psi_sovrl_restr.f90 index 3854040c..f51d98e2 100644 --- a/base/comm/internals/psi_sovrl_restr.f90 +++ b/base/comm/internals/psi_sovrl_restr.f90 @@ -47,7 +47,8 @@ subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_sovrl_restr_vect' @@ -56,8 +57,8 @@ subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -71,7 +72,7 @@ subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_restr_vect @@ -89,7 +90,8 @@ subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_sovrl_restr_mv' @@ -98,8 +100,8 @@ subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +114,7 @@ subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_restr_multivect diff --git a/base/comm/internals/psi_sovrl_restr_a.f90 b/base/comm/internals/psi_sovrl_restr_a.f90 index e66297d5..c1295187 100644 --- a/base/comm/internals/psi_sovrl_restr_a.f90 +++ b/base/comm/internals/psi_sovrl_restr_a.f90 @@ -45,7 +45,8 @@ subroutine psi_sovrl_restrr1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_sovrl_restrr1' @@ -54,8 +55,8 @@ subroutine psi_sovrl_restrr1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -72,7 +73,7 @@ subroutine psi_sovrl_restrr1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_restrr1 @@ -88,7 +89,8 @@ subroutine psi_sovrl_restrr2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_sovrl_restrr2' @@ -97,8 +99,8 @@ subroutine psi_sovrl_restrr2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -122,7 +124,7 @@ subroutine psi_sovrl_restrr2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_restrr2 diff --git a/base/comm/internals/psi_sovrl_save.f90 b/base/comm/internals/psi_sovrl_save.f90 index 9b06fef7..04fc3350 100644 --- a/base/comm/internals/psi_sovrl_save.f90 +++ b/base/comm/internals/psi_sovrl_save.f90 @@ -47,7 +47,8 @@ subroutine psi_sovrl_save_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_sovrl_save_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -77,13 +78,11 @@ subroutine psi_sovrl_save_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_save_vect - - subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_sovrl_save_multivect use psb_realloc_mod @@ -97,7 +96,8 @@ subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -106,8 +106,8 @@ subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -128,7 +128,7 @@ subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_save_multivect diff --git a/base/comm/internals/psi_sovrl_save_a.f90 b/base/comm/internals/psi_sovrl_save_a.f90 index cf400127..e2b57541 100644 --- a/base/comm/internals/psi_sovrl_save_a.f90 +++ b/base/comm/internals/psi_sovrl_save_a.f90 @@ -47,7 +47,8 @@ subroutine psi_sovrl_saver1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_sovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_sovrl_saver1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -80,7 +81,7 @@ subroutine psi_sovrl_saver1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_saver1 @@ -99,7 +100,8 @@ subroutine psi_sovrl_saver2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_sovrl_saver2' @@ -108,8 +110,8 @@ subroutine psi_sovrl_saver2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -133,7 +135,7 @@ subroutine psi_sovrl_saver2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_saver2 diff --git a/base/comm/internals/psi_sovrl_upd.f90 b/base/comm/internals/psi_sovrl_upd.f90 index 636261b1..046524ff 100644 --- a/base/comm/internals/psi_sovrl_upd.f90 +++ b/base/comm/internals/psi_sovrl_upd.f90 @@ -32,7 +32,7 @@ ! Subroutine: psi_sovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! ! @@ -50,7 +50,8 @@ subroutine psi_sovrl_upd_vect(x,desc_a,update,info) ! locals real(psb_spk_), allocatable :: xs(:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -61,8 +62,8 @@ subroutine psi_sovrl_upd_vect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +113,7 @@ subroutine psi_sovrl_upd_vect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_upd_vect @@ -131,7 +132,8 @@ subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) ! locals real(psb_spk_), allocatable :: xs(:,:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx, nc integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -142,8 +144,8 @@ subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -194,7 +196,7 @@ subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_upd_multivect diff --git a/base/comm/internals/psi_sovrl_upd_a.f90 b/base/comm/internals/psi_sovrl_upd_a.f90 index 82211657..4387492d 100644 --- a/base/comm/internals/psi_sovrl_upd_a.f90 +++ b/base/comm/internals/psi_sovrl_upd_a.f90 @@ -46,7 +46,8 @@ subroutine psi_sovrl_updr1(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -56,8 +57,8 @@ subroutine psi_sovrl_updr1(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,12 +99,11 @@ subroutine psi_sovrl_updr1(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_updr1 - subroutine psi_sovrl_updr2(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_sovrl_updr2 @@ -115,7 +115,8 @@ subroutine psi_sovrl_updr2(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -125,8 +126,8 @@ subroutine psi_sovrl_updr2(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -167,7 +168,7 @@ subroutine psi_sovrl_updr2(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sovrl_updr2 diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index b5185198..e4f11bd0 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -113,7 +113,9 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -121,9 +123,9 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -148,13 +150,13 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswapdata_vect @@ -173,7 +175,7 @@ end subroutine psi_sswapdata_vect ! ! ! -subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_sswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswap_vidx_vect @@ -190,8 +192,10 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y real(psb_spk_) :: beta real(psb_spk_), target :: work(:) @@ -199,8 +203,8 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -213,10 +217,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -260,7 +261,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & nesd = idx%v(pnti+nerv+psb_n_elem_send_) rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_real_swap_tag @@ -413,7 +414,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswap_vidx_vect @@ -450,7 +451,9 @@ subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -458,9 +461,9 @@ subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -485,13 +488,13 @@ subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswapdata_multivect @@ -510,7 +513,7 @@ end subroutine psi_sswapdata_multivect ! ! ! -subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_sswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswap_vidx_multivect @@ -527,8 +530,10 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y real(psb_spk_) :: beta real(psb_spk_), target :: work(:) @@ -536,8 +541,8 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -550,10 +555,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -599,7 +601,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_real_swap_tag @@ -756,7 +758,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswap_vidx_multivect diff --git a/base/comm/internals/psi_sswapdata_a.F90 b/base/comm/internals/psi_sswapdata_a.F90 index 5b591bf3..6ca2aa7c 100644 --- a/base/comm/internals/psi_sswapdata_a.F90 +++ b/base/comm/internals/psi_sswapdata_a.F90 @@ -106,7 +106,9 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -141,18 +143,18 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswapdatam -subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & +subroutine psi_sswapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswapidxm @@ -167,15 +169,18 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:,:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -192,10 +197,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -235,7 +237,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -314,14 +316,14 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -348,7 +350,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_real_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& @@ -433,7 +435,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -450,7 +452,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -498,7 +500,7 @@ subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswapidxm @@ -579,7 +581,9 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -587,9 +591,9 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -614,13 +618,13 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswapdatav @@ -636,7 +640,7 @@ end subroutine psi_sswapdatav ! ! ! -subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_sswapidxv(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswapidxv @@ -651,15 +655,17 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -676,10 +682,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -719,7 +722,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -799,14 +802,14 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -833,7 +836,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_real_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& @@ -917,7 +920,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -933,7 +936,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -980,7 +983,7 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswapidxv diff --git a/base/comm/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 index cb3ccc75..90c4b275 100644 --- a/base/comm/internals/psi_sswaptran.F90 +++ b/base/comm/internals/psi_sswaptran.F90 @@ -115,7 +115,9 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -123,9 +125,9 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -150,19 +152,17 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswaptran_vect - - ! ! ! Subroutine: psi_stran_vidx_vect @@ -176,7 +176,7 @@ end subroutine psi_sswaptran_vect ! ! ! -subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_stran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stran_vidx_vect @@ -193,7 +193,9 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y real(psb_spk_) :: beta @@ -202,8 +204,8 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -216,10 +218,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -266,7 +265,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt call mpi_irecv(y%combuf(snd_pt),nesd,& @@ -422,7 +421,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -463,7 +462,9 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -471,9 +472,9 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -498,13 +499,13 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswaptran_multivect @@ -523,7 +524,7 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! ! ! -subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_stran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stran_vidx_multivect @@ -540,7 +541,9 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y real(psb_spk_) :: beta @@ -549,8 +552,8 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -563,10 +566,7 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -613,7 +613,7 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt call mpi_irecv(y%combuf(snd_pt),n*nesd,& @@ -773,7 +773,7 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/internals/psi_sswaptran_a.F90 b/base/comm/internals/psi_sswaptran_a.F90 index 890a7a58..5b8bb75c 100644 --- a/base/comm/internals/psi_sswaptran_a.F90 +++ b/base/comm/internals/psi_sswaptran_a.F90 @@ -110,7 +110,9 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -118,10 +120,10 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -146,18 +148,18 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswaptranm -subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& +subroutine psi_stranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stranidxm @@ -172,15 +174,17 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:,:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -197,10 +201,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -240,7 +241,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -324,14 +325,14 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -358,7 +359,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_real_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& @@ -443,7 +444,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -460,7 +461,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -508,7 +509,7 @@ subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_stranidxm @@ -592,7 +593,9 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -600,9 +603,9 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -627,13 +630,13 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_sswaptranv @@ -649,7 +652,7 @@ end subroutine psi_sswaptranv ! ! ! -subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_stranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_stranidxv @@ -664,15 +667,22 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -689,10 +699,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -732,7 +739,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -817,14 +824,14 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -850,7 +857,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_real_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& @@ -933,7 +940,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -949,7 +956,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -996,7 +1003,7 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_stranidxv diff --git a/base/comm/internals/psi_zovrl_restr.f90 b/base/comm/internals/psi_zovrl_restr.f90 index e52232e7..0b127c3e 100644 --- a/base/comm/internals/psi_zovrl_restr.f90 +++ b/base/comm/internals/psi_zovrl_restr.f90 @@ -47,7 +47,8 @@ subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_zovrl_restr_vect' @@ -56,8 +57,8 @@ subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -71,7 +72,7 @@ subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_restr_vect @@ -89,7 +90,8 @@ subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_zovrl_restr_mv' @@ -98,8 +100,8 @@ subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +114,7 @@ subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_restr_multivect diff --git a/base/comm/internals/psi_zovrl_restr_a.f90 b/base/comm/internals/psi_zovrl_restr_a.f90 index 379efdcb..a823b73d 100644 --- a/base/comm/internals/psi_zovrl_restr_a.f90 +++ b/base/comm/internals/psi_zovrl_restr_a.f90 @@ -45,7 +45,8 @@ subroutine psi_zovrl_restrr1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_zovrl_restrr1' @@ -54,8 +55,8 @@ subroutine psi_zovrl_restrr1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -72,7 +73,7 @@ subroutine psi_zovrl_restrr1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_restrr1 @@ -88,7 +89,8 @@ subroutine psi_zovrl_restrr2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_zovrl_restrr2' @@ -97,8 +99,8 @@ subroutine psi_zovrl_restrr2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -122,7 +124,7 @@ subroutine psi_zovrl_restrr2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_restrr2 diff --git a/base/comm/internals/psi_zovrl_save.f90 b/base/comm/internals/psi_zovrl_save.f90 index acf65181..830479fe 100644 --- a/base/comm/internals/psi_zovrl_save.f90 +++ b/base/comm/internals/psi_zovrl_save.f90 @@ -47,7 +47,8 @@ subroutine psi_zovrl_save_vect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_zovrl_save_vect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -77,13 +78,11 @@ subroutine psi_zovrl_save_vect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_save_vect - - subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_zovrl_save_multivect use psb_realloc_mod @@ -97,7 +96,8 @@ subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_dovrl_saver1' @@ -106,8 +106,8 @@ subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -128,7 +128,7 @@ subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_save_multivect diff --git a/base/comm/internals/psi_zovrl_save_a.f90 b/base/comm/internals/psi_zovrl_save_a.f90 index 1e8fdb89..f2c09ee8 100644 --- a/base/comm/internals/psi_zovrl_save_a.f90 +++ b/base/comm/internals/psi_zovrl_save_a.f90 @@ -47,7 +47,8 @@ subroutine psi_zovrl_saver1(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz character(len=20) :: name, ch_err name='psi_zovrl_saver1' @@ -56,8 +57,8 @@ subroutine psi_zovrl_saver1(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -80,7 +81,7 @@ subroutine psi_zovrl_saver1(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_saver1 @@ -99,7 +100,8 @@ subroutine psi_zovrl_saver2(x,xs,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc character(len=20) :: name, ch_err name='psi_zovrl_saver2' @@ -108,8 +110,8 @@ subroutine psi_zovrl_saver2(x,xs,desc_a,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -133,7 +135,7 @@ subroutine psi_zovrl_saver2(x,xs,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_saver2 diff --git a/base/comm/internals/psi_zovrl_upd.f90 b/base/comm/internals/psi_zovrl_upd.f90 index cd7ea0de..f71862f7 100644 --- a/base/comm/internals/psi_zovrl_upd.f90 +++ b/base/comm/internals/psi_zovrl_upd.f90 @@ -32,7 +32,7 @@ ! Subroutine: psi_zovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! ! @@ -50,7 +50,8 @@ subroutine psi_zovrl_upd_vect(x,desc_a,update,info) ! locals complex(psb_dpk_), allocatable :: xs(:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -61,8 +62,8 @@ subroutine psi_zovrl_upd_vect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -112,7 +113,7 @@ subroutine psi_zovrl_upd_vect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_upd_vect @@ -131,7 +132,8 @@ subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) ! locals complex(psb_dpk_), allocatable :: xs(:,:) - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm, nx, nc integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -142,8 +144,8 @@ subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -194,7 +196,7 @@ subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_upd_multivect diff --git a/base/comm/internals/psi_zovrl_upd_a.f90 b/base/comm/internals/psi_zovrl_upd_a.f90 index 9ea2fbae..658bd317 100644 --- a/base/comm/internals/psi_zovrl_upd_a.f90 +++ b/base/comm/internals/psi_zovrl_upd_a.f90 @@ -46,7 +46,8 @@ subroutine psi_zovrl_updr1(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -56,8 +57,8 @@ subroutine psi_zovrl_updr1(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,12 +99,11 @@ subroutine psi_zovrl_updr1(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_updr1 - subroutine psi_zovrl_updr2(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_zovrl_updr2 @@ -115,7 +115,8 @@ subroutine psi_zovrl_updr2(x,desc_a,update,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -125,8 +126,8 @@ subroutine psi_zovrl_updr2(x,desc_a,update,info) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -167,7 +168,7 @@ subroutine psi_zovrl_updr2(x,desc_a,update,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zovrl_updr2 diff --git a/base/comm/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 index 7d34012e..991d6e40 100644 --- a/base/comm/internals/psi_zswapdata.F90 +++ b/base/comm/internals/psi_zswapdata.F90 @@ -113,7 +113,9 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -121,9 +123,9 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -148,13 +150,13 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswapdata_vect @@ -173,7 +175,7 @@ end subroutine psi_zswapdata_vect ! ! ! -subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_zswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswap_vidx_vect @@ -190,8 +192,10 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y complex(psb_dpk_) :: beta complex(psb_dpk_), target :: work(:) @@ -199,8 +203,8 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -213,10 +217,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -260,7 +261,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & nesd = idx%v(pnti+nerv+psb_n_elem_send_) rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_dcomplex_swap_tag @@ -413,7 +414,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswap_vidx_vect @@ -450,7 +451,9 @@ subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -458,9 +461,9 @@ subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -485,13 +488,13 @@ subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswapdata_multivect @@ -510,7 +513,7 @@ end subroutine psi_zswapdata_multivect ! ! ! -subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_zswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswap_vidx_multivect @@ -527,8 +530,10 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y complex(psb_dpk_) :: beta complex(psb_dpk_), target :: work(:) @@ -536,8 +541,8 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -550,10 +555,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -599,7 +601,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_dcomplex_swap_tag @@ -756,7 +758,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswap_vidx_multivect diff --git a/base/comm/internals/psi_zswapdata_a.F90 b/base/comm/internals/psi_zswapdata_a.F90 index 19026b97..43cf3325 100644 --- a/base/comm/internals/psi_zswapdata_a.F90 +++ b/base/comm/internals/psi_zswapdata_a.F90 @@ -106,7 +106,9 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -141,18 +143,18 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswapdatam -subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & +subroutine psi_zswapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswapidxm @@ -167,15 +169,18 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -192,10 +197,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & info=psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -235,7 +237,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -314,14 +316,14 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -348,7 +350,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_dcomplex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& @@ -433,7 +435,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -450,7 +452,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -498,7 +500,7 @@ subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswapidxm @@ -579,7 +581,9 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -587,9 +591,9 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -614,13 +618,13 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswapdatav @@ -636,7 +640,7 @@ end subroutine psi_zswapdatav ! ! ! -subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & +subroutine psi_zswapidxv(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswapidxv @@ -651,15 +655,17 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -676,10 +682,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & info=psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -719,7 +722,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -799,14 +802,14 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -833,7 +836,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = psb_dcomplex_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& @@ -917,7 +920,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& + if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -933,7 +936,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& + if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -980,7 +983,7 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswapidxv diff --git a/base/comm/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 index c78a5e1a..f027519f 100644 --- a/base/comm/internals/psi_zswaptran.F90 +++ b/base/comm/internals/psi_zswaptran.F90 @@ -115,7 +115,9 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -123,9 +125,9 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -150,19 +152,17 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswaptran_vect - - ! ! ! Subroutine: psi_ztran_vidx_vect @@ -176,7 +176,7 @@ end subroutine psi_zswaptran_vect ! ! ! -subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ztran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztran_vidx_vect @@ -193,7 +193,9 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y complex(psb_dpk_) :: beta @@ -202,8 +204,8 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -216,10 +218,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -266,7 +265,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt call mpi_irecv(y%combuf(snd_pt),nesd,& @@ -422,7 +421,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -463,7 +462,9 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx character(len=20) :: name @@ -471,9 +472,9 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -498,13 +499,13 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswaptran_multivect @@ -523,7 +524,7 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! ! ! -subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ztran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztran_vidx_multivect @@ -540,7 +541,9 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y complex(psb_dpk_) :: beta @@ -549,8 +552,8 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& @@ -563,10 +566,7 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -613,7 +613,7 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt call mpi_irecv(y%combuf(snd_pt),n*nesd,& @@ -773,7 +773,7 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/internals/psi_zswaptran_a.F90 b/base/comm/internals/psi_zswaptran_a.F90 index 46e4a898..9b065eb8 100644 --- a/base/comm/internals/psi_zswaptran_a.F90 +++ b/base/comm/internals/psi_zswaptran_a.F90 @@ -110,7 +110,9 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -118,10 +120,10 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -146,18 +148,18 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswaptranm -subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& +subroutine psi_ztranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztranidxm @@ -172,15 +174,17 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag,n + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -197,10 +201,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -240,7 +241,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = n*nerv @@ -324,14 +325,14 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -358,7 +359,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_dcomplex_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& @@ -443,7 +444,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -460,7 +461,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -508,7 +509,7 @@ subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_ztranidxm @@ -592,7 +593,9 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), optional :: data ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_), pointer :: d_idx(:) character(len=20) :: name @@ -600,9 +603,9 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) name='psi_swap_tranv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -627,13 +630,13 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_zswaptranv @@ -649,7 +652,7 @@ end subroutine psi_zswaptranv ! ! ! -subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& +subroutine psi_ztranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_ztranidxv @@ -664,15 +667,22 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +<<<<<<< HEAD + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +======= + integer(psb_ipk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret +>>>>>>> implement-ainv integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& & sdsz, rvsz, prcid, rvhd, sdhd integer(psb_ipk_) :: nesd, nerv,& @@ -689,10 +699,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& info=psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -732,7 +739,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) brvidx(proc_to_comm) = rcv_pt rvsz(proc_to_comm) = nerv @@ -817,14 +824,14 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& nesd = idx(pnti+nerv+psb_n_elem_send_) if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm == me) then if (nesd /= nerv) then @@ -850,7 +857,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = psb_dcomplex_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& @@ -933,7 +940,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& + if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -949,7 +956,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& proc_to_comm = idx(pnti+psb_proc_id_) nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& + if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) rcv_pt = rcv_pt + nerv snd_pt = snd_pt + nesd @@ -996,7 +1003,7 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(iictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_ztranidxv diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index f4ed3f4a..7893d7c3 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -57,7 +57,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_spk_), allocatable :: llocx(:) @@ -70,10 +71,10 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -148,12 +149,12 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -174,7 +175,8 @@ subroutine psb_cgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_spk_), allocatable :: llocx(:,:) @@ -187,10 +189,10 @@ subroutine psb_cgather_multivect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -264,12 +266,12 @@ subroutine psb_cgather_multivect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_cgather_a.f90 b/base/comm/psb_cgather_a.f90 index 5f75abd6..ac2e66e4 100644 --- a/base/comm/psb_cgather_a.f90 +++ b/base/comm/psb_cgather_a.f90 @@ -57,12 +57,12 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_cgatherm' info=psb_success_ @@ -71,9 +71,9 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +110,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) maxk = lock k = maxk - call psb_bcast(ictxt,k,root=iiroot) + call psb_bcast(ctxt,k,root=iiroot) ! there should be a global check on k here!!! @@ -157,12 +157,12 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) end do end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -231,7 +231,8 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx @@ -245,10 +246,10 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,12 +323,12 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 index ad483a51..7eca2d12 100644 --- a/base/comm/psb_chalo.f90 +++ b/base/comm/psb_chalo.f90 @@ -65,7 +65,8 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) @@ -80,10 +81,10 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -179,7 +180,7 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_chalo_vect @@ -219,7 +220,8 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) @@ -234,10 +236,10 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -334,7 +336,7 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_chalo_multivect diff --git a/base/comm/psb_chalo_a.f90 b/base/comm/psb_chalo_a.f90 index 5f18ebb6..b27ffe56 100644 --- a/base/comm/psb_chalo_a.f90 +++ b/base/comm/psb_chalo_a.f90 @@ -65,7 +65,8 @@ subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& & liwork,data_, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -81,10 +82,10 @@ subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +193,7 @@ subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_chalom @@ -266,7 +267,8 @@ subroutine psb_chalov(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) @@ -281,10 +283,10 @@ subroutine psb_chalov(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -373,7 +375,7 @@ subroutine psb_chalov(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_chalov diff --git a/base/comm/psb_covrl.f90 b/base/comm/psb_covrl.f90 index 7ac851b6..6ae6ce9f 100644 --- a/base/comm/psb_covrl.f90 +++ b/base/comm/psb_covrl.f90 @@ -75,7 +75,8 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) @@ -90,10 +91,10 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -175,7 +176,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_covrl_vect @@ -224,7 +225,8 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) @@ -239,10 +241,10 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -326,7 +328,7 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_covrl_multivect diff --git a/base/comm/psb_covrl_a.f90 b/base/comm/psb_covrl_a.f90 index 8949b7ed..d0f079ae 100644 --- a/base/comm/psb_covrl_a.f90 +++ b/base/comm/psb_covrl_a.f90 @@ -76,7 +76,8 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& & mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -92,10 +93,10 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -187,7 +188,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_covrlm @@ -265,7 +266,8 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, nrow, ncol, & & k, update_, mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) @@ -280,10 +282,10 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -368,7 +370,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_covrlv diff --git a/base/comm/psb_cscatter.F90 b/base/comm/psb_cscatter.F90 index 7ac22a68..8d1235db 100644 --- a/base/comm/psb_cscatter.F90 +++ b/base/comm/psb_cscatter.F90 @@ -54,7 +54,8 @@ subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_c_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx complex(psb_spk_), allocatable :: vlocx(:) @@ -67,13 +68,13 @@ subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -92,7 +93,7 @@ subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_cscatter_a.F90 b/base/comm/psb_cscatter_a.F90 index d16ae980..38d922e2 100644 --- a/base/comm/psb_cscatter_a.F90 +++ b/base/comm/psb_cscatter_a.F90 @@ -62,7 +62,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, iroot, icomm, myrank, rootrank, iam, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & col,pos @@ -79,10 +80,10 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -107,8 +108,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,me) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,me) if (iroot==-1) then lda_globx = size(globx, 1) @@ -159,7 +160,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -235,7 +236,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +307,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx @@ -322,13 +324,13 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -347,8 +349,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root) iroot = psb_root_ end if - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,iam) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,iam) iglobx = 1 jglobx = 1 @@ -394,7 +396,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root) locx(i)=globx(ltg(i)) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -472,7 +474,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index 72bfa774..9d50ef56 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -67,7 +67,8 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) @@ -82,9 +83,9 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -128,7 +129,7 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) nzg = sum(nzbr) if (nzg <0) then info = psb_err_mpi_int_ovflw_ @@ -216,7 +217,7 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -249,7 +250,8 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -264,9 +266,9 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -308,7 +310,7 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -388,7 +390,7 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -420,7 +422,8 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k integer(psb_ipk_) :: err_act, dupl_ integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -435,9 +438,9 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -479,7 +482,7 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -554,7 +557,7 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index c767c8ec..8109d506 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -57,7 +57,8 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_dpk_), allocatable :: llocx(:) @@ -70,10 +71,10 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -148,12 +149,12 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -174,7 +175,8 @@ subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_dpk_), allocatable :: llocx(:,:) @@ -187,10 +189,10 @@ subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -264,12 +266,12 @@ subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_dgather_a.f90 b/base/comm/psb_dgather_a.f90 index 5ae9ed50..1e03ccfd 100644 --- a/base/comm/psb_dgather_a.f90 +++ b/base/comm/psb_dgather_a.f90 @@ -57,12 +57,12 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_dgatherm' info=psb_success_ @@ -71,9 +71,9 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +110,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) maxk = lock k = maxk - call psb_bcast(ictxt,k,root=iiroot) + call psb_bcast(ctxt,k,root=iiroot) ! there should be a global check on k here!!! @@ -157,12 +157,12 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) end do end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -231,7 +231,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx @@ -245,10 +246,10 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,12 +323,12 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index b5f584dc..080631e1 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -65,7 +65,8 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) @@ -80,10 +81,10 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -179,7 +180,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dhalo_vect @@ -219,7 +220,8 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) @@ -234,10 +236,10 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -334,7 +336,7 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dhalo_multivect diff --git a/base/comm/psb_dhalo_a.f90 b/base/comm/psb_dhalo_a.f90 index bee4cd18..ccbc169d 100644 --- a/base/comm/psb_dhalo_a.f90 +++ b/base/comm/psb_dhalo_a.f90 @@ -65,7 +65,8 @@ subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& & liwork,data_, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -81,10 +82,10 @@ subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +193,7 @@ subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dhalom @@ -266,7 +267,8 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) @@ -281,10 +283,10 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -373,7 +375,7 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dhalov diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index 1177be29..f0905278 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -75,7 +75,8 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) @@ -90,10 +91,10 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -175,7 +176,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dovrl_vect @@ -224,7 +225,8 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) @@ -239,10 +241,10 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -326,7 +328,7 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dovrl_multivect diff --git a/base/comm/psb_dovrl_a.f90 b/base/comm/psb_dovrl_a.f90 index 5ef1738d..e005a393 100644 --- a/base/comm/psb_dovrl_a.f90 +++ b/base/comm/psb_dovrl_a.f90 @@ -76,7 +76,8 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& & mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -92,10 +93,10 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -187,7 +188,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dovrlm @@ -265,7 +266,8 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, nrow, ncol, & & k, update_, mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) @@ -280,10 +282,10 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -368,7 +370,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dovrlv diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index 157af3c6..3465333b 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -54,7 +54,8 @@ subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_d_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx real(psb_dpk_), allocatable :: vlocx(:) @@ -67,13 +68,13 @@ subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -92,7 +93,7 @@ subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_dscatter_a.F90 b/base/comm/psb_dscatter_a.F90 index e0b39f57..0f3be5aa 100644 --- a/base/comm/psb_dscatter_a.F90 +++ b/base/comm/psb_dscatter_a.F90 @@ -62,7 +62,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, iroot, icomm, myrank, rootrank, iam, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & col,pos @@ -79,10 +80,10 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -107,8 +108,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,me) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,me) if (iroot==-1) then lda_globx = size(globx, 1) @@ -159,7 +160,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -235,7 +236,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +307,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx @@ -322,13 +324,13 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -347,8 +349,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root) iroot = psb_root_ end if - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,iam) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,iam) iglobx = 1 jglobx = 1 @@ -394,7 +396,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root) locx(i)=globx(ltg(i)) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -472,7 +474,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index a29ac002..13d04d7b 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -67,7 +67,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) @@ -82,9 +83,9 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -128,7 +129,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) nzg = sum(nzbr) if (nzg <0) then info = psb_err_mpi_int_ovflw_ @@ -216,7 +217,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -249,7 +250,8 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -264,9 +266,9 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -308,7 +310,7 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -388,7 +390,7 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -420,7 +422,8 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k integer(psb_ipk_) :: err_act, dupl_ integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -435,9 +438,9 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -479,7 +482,7 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -554,7 +557,7 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_egather_a.f90 b/base/comm/psb_egather_a.f90 index b910a4f7..b777cebd 100644 --- a/base/comm/psb_egather_a.f90 +++ b/base/comm/psb_egather_a.f90 @@ -57,12 +57,12 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_egatherm' info=psb_success_ @@ -71,9 +71,9 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +110,7 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot) maxk = lock k = maxk - call psb_bcast(ictxt,k,root=iiroot) + call psb_bcast(ctxt,k,root=iiroot) ! there should be a global check on k here!!! @@ -157,12 +157,12 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot) end do end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -231,7 +231,8 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx @@ -245,10 +246,10 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,12 +323,12 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_ehalo_a.f90 b/base/comm/psb_ehalo_a.f90 index 42a47a16..03aa1e3f 100644 --- a/base/comm/psb_ehalo_a.f90 +++ b/base/comm/psb_ehalo_a.f90 @@ -65,7 +65,8 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& & liwork,data_, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -81,10 +82,10 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +193,7 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ehalom @@ -266,7 +267,8 @@ subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_epk_),pointer :: iwork(:) @@ -281,10 +283,10 @@ subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -373,7 +375,7 @@ subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ehalov diff --git a/base/comm/psb_eovrl_a.f90 b/base/comm/psb_eovrl_a.f90 index 4b9372d4..fc6a868d 100644 --- a/base/comm/psb_eovrl_a.f90 +++ b/base/comm/psb_eovrl_a.f90 @@ -76,7 +76,8 @@ subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& & mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -92,10 +93,10 @@ subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -187,7 +188,7 @@ subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_eovrlm @@ -265,7 +266,8 @@ subroutine psb_eovrlv(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, nrow, ncol, & & k, update_, mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx integer(psb_epk_),pointer :: iwork(:) @@ -280,10 +282,10 @@ subroutine psb_eovrlv(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -368,7 +370,7 @@ subroutine psb_eovrlv(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_eovrlv diff --git a/base/comm/psb_escatter_a.F90 b/base/comm/psb_escatter_a.F90 index dbb2026f..e2b45f5c 100644 --- a/base/comm/psb_escatter_a.F90 +++ b/base/comm/psb_escatter_a.F90 @@ -62,7 +62,8 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, iroot, icomm, myrank, rootrank, iam, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & col,pos @@ -79,10 +80,10 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -107,8 +108,8 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,me) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,me) if (iroot==-1) then lda_globx = size(globx, 1) @@ -159,7 +160,7 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -235,7 +236,7 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +307,8 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx @@ -322,13 +324,13 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -347,8 +349,8 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root) iroot = psb_root_ end if - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,iam) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,iam) iglobx = 1 jglobx = 1 @@ -394,7 +396,7 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root) locx(i)=globx(ltg(i)) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -472,7 +474,7 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_i2gather_a.f90 b/base/comm/psb_i2gather_a.f90 index 9a671ef6..e0e1ed7a 100644 --- a/base/comm/psb_i2gather_a.f90 +++ b/base/comm/psb_i2gather_a.f90 @@ -57,12 +57,12 @@ subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_i2gatherm' info=psb_success_ @@ -71,9 +71,9 @@ subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +110,7 @@ subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot) maxk = lock k = maxk - call psb_bcast(ictxt,k,root=iiroot) + call psb_bcast(ctxt,k,root=iiroot) ! there should be a global check on k here!!! @@ -157,12 +157,12 @@ subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot) end do end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -231,7 +231,8 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx @@ -245,10 +246,10 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,12 +323,12 @@ subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_i2halo_a.f90 b/base/comm/psb_i2halo_a.f90 index f9c17fa5..d49d71c6 100644 --- a/base/comm/psb_i2halo_a.f90 +++ b/base/comm/psb_i2halo_a.f90 @@ -65,7 +65,8 @@ subroutine psb_i2halom(x,desc_a,info,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& & liwork,data_, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -81,10 +82,10 @@ subroutine psb_i2halom(x,desc_a,info,jx,ik,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +193,7 @@ subroutine psb_i2halom(x,desc_a,info,jx,ik,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_i2halom @@ -266,7 +267,8 @@ subroutine psb_i2halov(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_i2pk_),pointer :: iwork(:) @@ -281,10 +283,10 @@ subroutine psb_i2halov(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -373,7 +375,7 @@ subroutine psb_i2halov(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_i2halov diff --git a/base/comm/psb_i2ovrl_a.f90 b/base/comm/psb_i2ovrl_a.f90 index 8d056e39..f7ccd7a6 100644 --- a/base/comm/psb_i2ovrl_a.f90 +++ b/base/comm/psb_i2ovrl_a.f90 @@ -76,7 +76,8 @@ subroutine psb_i2ovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& & mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -92,10 +93,10 @@ subroutine psb_i2ovrlm(x,desc_a,info,jx,ik,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -187,7 +188,7 @@ subroutine psb_i2ovrlm(x,desc_a,info,jx,ik,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_i2ovrlm @@ -265,7 +266,8 @@ subroutine psb_i2ovrlv(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, nrow, ncol, & & k, update_, mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx integer(psb_i2pk_),pointer :: iwork(:) @@ -280,10 +282,10 @@ subroutine psb_i2ovrlv(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -368,7 +370,7 @@ subroutine psb_i2ovrlv(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_i2ovrlv diff --git a/base/comm/psb_i2scatter_a.F90 b/base/comm/psb_i2scatter_a.F90 index 4a72458e..960e48b0 100644 --- a/base/comm/psb_i2scatter_a.F90 +++ b/base/comm/psb_i2scatter_a.F90 @@ -62,7 +62,8 @@ subroutine psb_i2scatterm(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, iroot, icomm, myrank, rootrank, iam, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & col,pos @@ -79,10 +80,10 @@ subroutine psb_i2scatterm(globx, locx, desc_a, info, root) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -107,8 +108,8 @@ subroutine psb_i2scatterm(globx, locx, desc_a, info, root) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,me) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,me) if (iroot==-1) then lda_globx = size(globx, 1) @@ -159,7 +160,7 @@ subroutine psb_i2scatterm(globx, locx, desc_a, info, root) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -235,7 +236,7 @@ subroutine psb_i2scatterm(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +307,8 @@ subroutine psb_i2scatterv(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx @@ -322,13 +324,13 @@ subroutine psb_i2scatterv(globx, locx, desc_a, info, root) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -347,8 +349,8 @@ subroutine psb_i2scatterv(globx, locx, desc_a, info, root) iroot = psb_root_ end if - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,iam) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,iam) iglobx = 1 jglobx = 1 @@ -394,7 +396,7 @@ subroutine psb_i2scatterv(globx, locx, desc_a, info, root) locx(i)=globx(ltg(i)) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -472,7 +474,7 @@ subroutine psb_i2scatterv(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 48a4f2fe..2a01ee44 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -57,7 +57,8 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_ipk_), allocatable :: llocx(:) @@ -70,10 +71,10 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -148,12 +149,12 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -174,7 +175,8 @@ subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_ipk_), allocatable :: llocx(:,:) @@ -187,10 +189,10 @@ subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -264,12 +266,12 @@ subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index 4bccfc10..57e52958 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -65,7 +65,8 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) @@ -80,10 +81,10 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -179,7 +180,7 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ihalo_vect @@ -219,7 +220,8 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) @@ -234,10 +236,10 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -334,7 +336,7 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ihalo_multivect diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 index 06f720b0..3dd459f1 100644 --- a/base/comm/psb_iovrl.f90 +++ b/base/comm/psb_iovrl.f90 @@ -75,7 +75,8 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) @@ -90,10 +91,10 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -175,7 +176,7 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_iovrl_vect @@ -224,7 +225,8 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) @@ -239,10 +241,10 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -326,7 +328,7 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_iovrl_multivect diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index f159d5b4..57268e71 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -54,7 +54,8 @@ subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_i_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_ipk_), allocatable :: vlocx(:) @@ -67,13 +68,13 @@ subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -92,7 +93,7 @@ subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_ispgather.F90 b/base/comm/psb_ispgather.F90 index ed723289..e45f0f5d 100644 --- a/base/comm/psb_ispgather.F90 +++ b/base/comm/psb_ispgather.F90 @@ -67,7 +67,8 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) @@ -82,9 +83,9 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -128,7 +129,7 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) nzg = sum(nzbr) if (nzg <0) then info = psb_err_mpi_int_ovflw_ @@ -216,7 +217,7 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -249,7 +250,8 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -264,9 +266,9 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -308,7 +310,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -388,7 +390,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -420,7 +422,8 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn integer(psb_ipk_) :: err_act, dupl_ integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -435,9 +438,9 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -479,7 +482,7 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -554,7 +557,7 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_lgather.f90 b/base/comm/psb_lgather.f90 index 1f6f448f..eeb5a25d 100644 --- a/base/comm/psb_lgather.f90 +++ b/base/comm/psb_lgather.f90 @@ -57,7 +57,8 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_lpk_), allocatable :: llocx(:) @@ -70,10 +71,10 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -148,12 +149,12 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -174,7 +175,8 @@ subroutine psb_lgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_lpk_), allocatable :: llocx(:,:) @@ -187,10 +189,10 @@ subroutine psb_lgather_multivect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -264,12 +266,12 @@ subroutine psb_lgather_multivect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_lhalo.f90 b/base/comm/psb_lhalo.f90 index b35613a1..3a188561 100644 --- a/base/comm/psb_lhalo.f90 +++ b/base/comm/psb_lhalo.f90 @@ -65,7 +65,8 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_lpk_),pointer :: iwork(:) @@ -80,10 +81,10 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -179,7 +180,7 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_lhalo_vect @@ -219,7 +220,8 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_lpk_),pointer :: iwork(:) @@ -234,10 +236,10 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -334,7 +336,7 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_lhalo_multivect diff --git a/base/comm/psb_lovrl.f90 b/base/comm/psb_lovrl.f90 index bb3ece65..43de77bb 100644 --- a/base/comm/psb_lovrl.f90 +++ b/base/comm/psb_lovrl.f90 @@ -75,7 +75,8 @@ subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_lpk_),pointer :: iwork(:) @@ -90,10 +91,10 @@ subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -175,7 +176,7 @@ subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_lovrl_vect @@ -224,7 +225,8 @@ subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_lpk_),pointer :: iwork(:) @@ -239,10 +241,10 @@ subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -326,7 +328,7 @@ subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_lovrl_multivect diff --git a/base/comm/psb_lscatter.F90 b/base/comm/psb_lscatter.F90 index ceb60e4f..0ebbe28e 100644 --- a/base/comm/psb_lscatter.F90 +++ b/base/comm/psb_lscatter.F90 @@ -54,7 +54,8 @@ subroutine psb_lscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_l_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_), allocatable :: vlocx(:) @@ -67,13 +68,13 @@ subroutine psb_lscatter_vect(globx, locx, desc_a, info, root, mold) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -92,7 +93,7 @@ subroutine psb_lscatter_vect(globx, locx, desc_a, info, root, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_lspgather.F90 b/base/comm/psb_lspgather.F90 index 5d2d33e9..aa7b8fcc 100644 --- a/base/comm/psb_lspgather.F90 +++ b/base/comm/psb_lspgather.F90 @@ -67,7 +67,8 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) @@ -82,9 +83,9 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -128,7 +129,7 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) nzg = sum(nzbr) if (nzg <0) then info = psb_err_mpi_int_ovflw_ @@ -216,7 +217,7 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -249,7 +250,8 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -264,9 +266,9 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -308,7 +310,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -388,7 +390,7 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -420,7 +422,8 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn integer(psb_ipk_) :: err_act, dupl_ integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -435,9 +438,9 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -479,7 +482,7 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -554,7 +557,7 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_mgather_a.f90 b/base/comm/psb_mgather_a.f90 index 251e06c9..df574ea2 100644 --- a/base/comm/psb_mgather_a.f90 +++ b/base/comm/psb_mgather_a.f90 @@ -57,12 +57,12 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_mgatherm' info=psb_success_ @@ -71,9 +71,9 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +110,7 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot) maxk = lock k = maxk - call psb_bcast(ictxt,k,root=iiroot) + call psb_bcast(ctxt,k,root=iiroot) ! there should be a global check on k here!!! @@ -157,12 +157,12 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot) end do end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -231,7 +231,8 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx @@ -245,10 +246,10 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,12 +323,12 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_mhalo_a.f90 b/base/comm/psb_mhalo_a.f90 index f6745cd4..cb9ffec1 100644 --- a/base/comm/psb_mhalo_a.f90 +++ b/base/comm/psb_mhalo_a.f90 @@ -65,7 +65,8 @@ subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& & liwork,data_, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -81,10 +82,10 @@ subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +193,7 @@ subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_mhalom @@ -266,7 +267,8 @@ subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx integer(psb_mpk_),pointer :: iwork(:) @@ -281,10 +283,10 @@ subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -373,7 +375,7 @@ subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_mhalov diff --git a/base/comm/psb_movrl_a.f90 b/base/comm/psb_movrl_a.f90 index 9d8beae9..42d7d82d 100644 --- a/base/comm/psb_movrl_a.f90 +++ b/base/comm/psb_movrl_a.f90 @@ -76,7 +76,8 @@ subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& & mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -92,10 +93,10 @@ subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -187,7 +188,7 @@ subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_movrlm @@ -265,7 +266,8 @@ subroutine psb_movrlv(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, nrow, ncol, & & k, update_, mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx integer(psb_mpk_),pointer :: iwork(:) @@ -280,10 +282,10 @@ subroutine psb_movrlv(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -368,7 +370,7 @@ subroutine psb_movrlv(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_movrlv diff --git a/base/comm/psb_mscatter_a.F90 b/base/comm/psb_mscatter_a.F90 index f85a3849..2c6d9fbb 100644 --- a/base/comm/psb_mscatter_a.F90 +++ b/base/comm/psb_mscatter_a.F90 @@ -62,7 +62,8 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, iroot, icomm, myrank, rootrank, iam, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & col,pos @@ -79,10 +80,10 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -107,8 +108,8 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,me) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,me) if (iroot==-1) then lda_globx = size(globx, 1) @@ -159,7 +160,7 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -235,7 +236,7 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +307,8 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx @@ -322,13 +324,13 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -347,8 +349,8 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root) iroot = psb_root_ end if - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,iam) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,iam) iglobx = 1 jglobx = 1 @@ -394,7 +396,7 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root) locx(i)=globx(ltg(i)) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -472,7 +474,7 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 538d1c43..857f5fd6 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -57,7 +57,8 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_spk_), allocatable :: llocx(:) @@ -70,10 +71,10 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -148,12 +149,12 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -174,7 +175,8 @@ subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_spk_), allocatable :: llocx(:,:) @@ -187,10 +189,10 @@ subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -264,12 +266,12 @@ subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_sgather_a.f90 b/base/comm/psb_sgather_a.f90 index 47a8c79a..28d5f5dc 100644 --- a/base/comm/psb_sgather_a.f90 +++ b/base/comm/psb_sgather_a.f90 @@ -57,12 +57,12 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_sgatherm' info=psb_success_ @@ -71,9 +71,9 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +110,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) maxk = lock k = maxk - call psb_bcast(ictxt,k,root=iiroot) + call psb_bcast(ctxt,k,root=iiroot) ! there should be a global check on k here!!! @@ -157,12 +157,12 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) end do end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -231,7 +231,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx @@ -245,10 +246,10 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,12 +323,12 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 index 78ab39e3..412fc75f 100644 --- a/base/comm/psb_shalo.f90 +++ b/base/comm/psb_shalo.f90 @@ -65,7 +65,8 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) @@ -80,10 +81,10 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -179,7 +180,7 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_shalo_vect @@ -219,7 +220,8 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) @@ -234,10 +236,10 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -334,7 +336,7 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_shalo_multivect diff --git a/base/comm/psb_shalo_a.f90 b/base/comm/psb_shalo_a.f90 index 9d1a5717..0030d5c9 100644 --- a/base/comm/psb_shalo_a.f90 +++ b/base/comm/psb_shalo_a.f90 @@ -65,7 +65,8 @@ subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& & liwork,data_, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -81,10 +82,10 @@ subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +193,7 @@ subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_shalom @@ -266,7 +267,8 @@ subroutine psb_shalov(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) @@ -281,10 +283,10 @@ subroutine psb_shalov(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -373,7 +375,7 @@ subroutine psb_shalov(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_shalov diff --git a/base/comm/psb_sovrl.f90 b/base/comm/psb_sovrl.f90 index 3930645a..05c5ade2 100644 --- a/base/comm/psb_sovrl.f90 +++ b/base/comm/psb_sovrl.f90 @@ -75,7 +75,8 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) @@ -90,10 +91,10 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -175,7 +176,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sovrl_vect @@ -224,7 +225,8 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) @@ -239,10 +241,10 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -326,7 +328,7 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sovrl_multivect diff --git a/base/comm/psb_sovrl_a.f90 b/base/comm/psb_sovrl_a.f90 index b2f19fdd..9944036d 100644 --- a/base/comm/psb_sovrl_a.f90 +++ b/base/comm/psb_sovrl_a.f90 @@ -76,7 +76,8 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& & mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -92,10 +93,10 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -187,7 +188,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sovrlm @@ -265,7 +266,8 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, nrow, ncol, & & k, update_, mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) @@ -280,10 +282,10 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -368,7 +370,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sovrlv diff --git a/base/comm/psb_sscatter.F90 b/base/comm/psb_sscatter.F90 index 960c5bac..f2b79e83 100644 --- a/base/comm/psb_sscatter.F90 +++ b/base/comm/psb_sscatter.F90 @@ -54,7 +54,8 @@ subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_s_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx real(psb_spk_), allocatable :: vlocx(:) @@ -67,13 +68,13 @@ subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -92,7 +93,7 @@ subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_sscatter_a.F90 b/base/comm/psb_sscatter_a.F90 index d756b712..08026536 100644 --- a/base/comm/psb_sscatter_a.F90 +++ b/base/comm/psb_sscatter_a.F90 @@ -62,7 +62,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, iroot, icomm, myrank, rootrank, iam, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & col,pos @@ -79,10 +80,10 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -107,8 +108,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,me) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,me) if (iroot==-1) then lda_globx = size(globx, 1) @@ -159,7 +160,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -235,7 +236,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +307,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx @@ -322,13 +324,13 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -347,8 +349,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root) iroot = psb_root_ end if - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,iam) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,iam) iglobx = 1 jglobx = 1 @@ -394,7 +396,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root) locx(i)=globx(ltg(i)) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -472,7 +474,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index 83db9c08..5678b676 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -67,7 +67,8 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) @@ -82,9 +83,9 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -128,7 +129,7 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) nzg = sum(nzbr) if (nzg <0) then info = psb_err_mpi_int_ovflw_ @@ -216,7 +217,7 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -249,7 +250,8 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -264,9 +266,9 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -308,7 +310,7 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -388,7 +390,7 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -420,7 +422,8 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k integer(psb_ipk_) :: err_act, dupl_ integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -435,9 +438,9 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -479,7 +482,7 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -554,7 +557,7 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index b8b9a6c8..b163094a 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -57,7 +57,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_dpk_), allocatable :: llocx(:) @@ -70,10 +71,10 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -148,12 +149,12 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -174,7 +175,8 @@ subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_dpk_), allocatable :: llocx(:,:) @@ -187,10 +189,10 @@ subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -264,12 +266,12 @@ subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_zgather_a.f90 b/base/comm/psb_zgather_a.f90 index 1c3838cb..fa5f288b 100644 --- a/base/comm/psb_zgather_a.f90 +++ b/base/comm/psb_zgather_a.f90 @@ -57,12 +57,12 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx - - character(len=20) :: name, ch_err + character(len=20) :: name, ch_err name='psb_zgatherm' info=psb_success_ @@ -71,9 +71,9 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +110,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) maxk = lock k = maxk - call psb_bcast(ictxt,k,root=iiroot) + call psb_bcast(ctxt,k,root=iiroot) ! there should be a global check on k here!!! @@ -157,12 +157,12 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) end do end do - call psb_sum(ictxt,globx(1:m,1:k),root=root) + call psb_sum(ctxt,globx(1:m,1:k),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -231,7 +231,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, root, iiroot, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& & maxk, k, jlx, ilx, i, j integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx @@ -245,10 +246,10 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,12 +323,12 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) end if end do - call psb_sum(ictxt,globx(1:m),root=root) + call psb_sum(ctxt,globx(1:m),root=root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index 595cbc03..2bf1aef2 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -65,7 +65,8 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) @@ -80,10 +81,10 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -179,7 +180,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zhalo_vect @@ -219,7 +220,8 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) @@ -234,10 +236,10 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -334,7 +336,7 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zhalo_multivect diff --git a/base/comm/psb_zhalo_a.f90 b/base/comm/psb_zhalo_a.f90 index c9a6b8a7..4855592a 100644 --- a/base/comm/psb_zhalo_a.f90 +++ b/base/comm/psb_zhalo_a.f90 @@ -65,7 +65,8 @@ subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& & liwork,data_, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -81,10 +82,10 @@ subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +193,7 @@ subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zhalom @@ -266,7 +267,8 @@ subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) @@ -281,10 +283,10 @@ subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -373,7 +375,7 @@ subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zhalov diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index c7463e19..02a2a73d 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -75,7 +75,8 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) @@ -90,10 +91,10 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -175,7 +176,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zovrl_vect @@ -224,7 +225,8 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, liwork, data_, update_, mode_ integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) @@ -239,10 +241,10 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -326,7 +328,7 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zovrl_multivect diff --git a/base/comm/psb_zovrl_a.f90 b/base/comm/psb_zovrl_a.f90 index 49a60740..6af46069 100644 --- a/base/comm/psb_zovrl_a.f90 +++ b/base/comm/psb_zovrl_a.f90 @@ -76,7 +76,8 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode ! locals - integer(psb_mpk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& & mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx @@ -92,10 +93,10 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -187,7 +188,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zovrlm @@ -265,7 +266,8 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, nrow, ncol, & & k, update_, mode_, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) @@ -280,10 +282,10 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -368,7 +370,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zovrlv diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index 10c2c78d..f8d2102b 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -54,7 +54,8 @@ subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_z_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx complex(psb_dpk_), allocatable :: vlocx(:) @@ -67,13 +68,13 @@ subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -92,7 +93,7 @@ subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_zscatter_a.F90 b/base/comm/psb_zscatter_a.F90 index b206d8d3..aaa684b6 100644 --- a/base/comm/psb_zscatter_a.F90 +++ b/base/comm/psb_zscatter_a.F90 @@ -62,7 +62,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, iroot, icomm, myrank, rootrank, iam, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & col,pos @@ -79,10 +80,10 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -107,8 +108,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root) m = desc_a%get_global_rows() n = desc_a%get_global_cols() - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,me) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,me) if (iroot==-1) then lda_globx = size(globx, 1) @@ -159,7 +160,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -235,7 +236,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +307,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root) ! locals - integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr integer(psb_ipk_) :: ierr(5), err_act, nrow,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx @@ -322,13 +324,13 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() ! check on blacs grid - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -347,8 +349,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root) iroot = psb_root_ end if - icomm = psb_get_mpi_comm(ictxt) - myrank = psb_get_mpi_rank(ictxt,iam) + icomm = psb_get_mpi_comm(ctxt) + myrank = psb_get_mpi_rank(ctxt,iam) iglobx = 1 jglobx = 1 @@ -394,7 +396,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root) locx(i)=globx(ltg(i)) end do else - rootrank = psb_get_mpi_rank(ictxt,iroot) + rootrank = psb_get_mpi_rank(ctxt,iroot) ! ! This is potentially unsafe when IPK=8 ! But then, IPK=8 is highly experimental anyway. @@ -472,7 +474,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index 98b7d215..6b59caa8 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -67,7 +67,8 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) @@ -82,9 +83,9 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -128,7 +129,7 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) nzg = sum(nzbr) if (nzg <0) then info = psb_err_mpi_int_ovflw_ @@ -216,7 +217,7 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -249,7 +250,8 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee integer(psb_ipk_) :: err_act, dupl_ integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -264,9 +266,9 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -308,7 +310,7 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -388,7 +390,7 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return @@ -420,7 +422,8 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k integer(psb_ipk_) :: err_act, dupl_ integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl logical :: keepnum_, keeploc_ - integer(psb_mpk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_mpk_) :: icomm, minfo, ndx, root_ integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_), allocatable :: lnzbr(:) @@ -435,9 +438,9 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (present(keepnum)) then keepnum_ = keepnum @@ -479,7 +482,7 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') nzbr(:) = 0 nzbr(me+1) = nzl - call psb_sum(ictxt,nzbr(1:np)) + call psb_sum(ctxt,nzbr(1:np)) lnzbr = nzbr nzg = sum(nzbr) if ((nzg < 0).or.(nzg /= sum(lnzbr))) then @@ -554,7 +557,7 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k 9999 continue call psb_errpush(info,name) - call psb_error_handler(ione*ictxt,err_act) + call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/Makefile b/base/internals/Makefile index cbb282a9..b3a1a995 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -1,12 +1,12 @@ include ../../Make.inc -FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ +FOBJS = psi_crea_bnd_elem.o psi_crea_index.o \ psi_crea_ovr_elem.o psi_bld_tmpovrl.o \ psi_bld_tmphalo.o psi_sort_dl.o \ psi_indx_map_fnd_owner.o \ psi_desc_impl.o psi_hash_impl.o psi_srtlist.o \ psi_bld_glb_dep_list.o psi_xtr_loc_dl.o -#psi_list_search.o psi_dl_check.o +#psi_list_search.o psi_dl_check.o psi_compute_size.o MPFOBJS = psi_desc_index.o psi_extrct_dl.o psi_fnd_owner.o psi_a2a_fnd_owner.o \ psi_graph_fnd_owner.o psi_adjcncy_fnd_owner.o psi_symm_dep_list.o diff --git a/base/internals/psi_a2a_fnd_owner.F90 b/base/internals/psi_a2a_fnd_owner.F90 index b9cd9bb2..1e0a1ab3 100644 --- a/base/internals/psi_a2a_fnd_owner.F90 +++ b/base/internals/psi_a2a_fnd_owner.F90 @@ -74,27 +74,27 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info,samesize) integer(psb_ipk_), allocatable :: tproc(:), lclidx(:) integer(psb_mpk_), allocatable :: hsz(:),hidx(:), sdidx(:), rvidx(:),& & sdsz(:), rvsz(:), sdhd(:), rvhd(:), p2pstat(:,:) - integer(psb_mpk_) :: icomm, minfo, iictxt,nv + integer(psb_mpk_) :: icomm, minfo, nv integer(psb_ipk_) :: i,n_row,n_col,err_act,gsz integer(psb_lpk_) :: mglob, ih - integer(psb_ipk_) :: ictxt,np,me, nresp - logical, parameter :: use_psi_adj=.true. - real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx - character(len=20) :: name - logical :: samesize_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, nresp + logical, parameter :: use_psi_adj=.true. + real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx + character(len=20) :: name + logical :: samesize_ info = psb_success_ name = 'psi_a2a_fnd_owner' call psb_erractionsave(err_act) - ictxt = idxmap%get_ctxt() + ctxt = idxmap%get_ctxt() icomm = idxmap%get_mpic() mglob = idxmap%get_gr() n_row = idxmap%get_lr() n_col = idxmap%get_lc() - iictxt = ictxt - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -200,7 +200,7 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info,samesize) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_adjcncy_fnd_owner.F90 b/base/internals/psi_adjcncy_fnd_owner.F90 index f26bb38f..cc215ca9 100644 --- a/base/internals/psi_adjcncy_fnd_owner.F90 +++ b/base/internals/psi_adjcncy_fnd_owner.F90 @@ -81,11 +81,12 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) integer(psb_mpk_), allocatable :: hsz(:),hidx(:), sdidx(:), rvidx(:),& & sdsz(:), rvsz(:), sdhd(:), rvhd(:), p2pstat(:,:) integer(psb_mpk_) :: prc, p2ptag, iret - integer(psb_mpk_) :: icomm, minfo, iictxt + integer(psb_mpk_) :: icomm, minfo integer(psb_ipk_) :: i,n_row,n_col,err_act,hsize,ip,isz,j, k,& & last_ih, last_j, nidx, nrecv, nadj integer(psb_lpk_) :: mglob, ih - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: gettime=.true., debug=.false. integer(psb_mpk_) :: xchg_alg logical, parameter :: do_timings=.false. @@ -98,12 +99,12 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) name = 'psi_adjcncy_fnd_owner' call psb_erractionsave(err_act) - ictxt = idxmap%get_ctxt() + ctxt = idxmap%get_ctxt() icomm = idxmap%get_mpic() mglob = idxmap%get_gr() n_row = idxmap%get_lr() n_col = idxmap%get_lc() - iictxt = ictxt + if ((do_timings).and.(idx_phase1==-1)) & & idx_phase1 = psb_get_timer_idx("ADJ_FND_OWN: phase1 ") if ((do_timings).and.(idx_phase2==-1)) & @@ -118,7 +119,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) & idx_phase13 = psb_get_timer_idx("ADJ_FND_OWN: phase13") - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -279,7 +280,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) do i = 0, np-1 if (rvsz(i)>0) then ! write(0,*) me, ' First receive from ',i,rvsz(i) - prc = psb_get_mpi_rank(ictxt,i) + prc = psb_get_mpi_rank(ctxt,i) p2ptag = psb_long_swap_tag !write(0,*) me, ' Posting first receive from ',i,rvsz(i),prc call mpi_irecv(rmtidx(hidx(i)+1),rvsz(i),& @@ -291,7 +292,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) if (do_timings) call psb_tic(idx_phase12) do j=1, nadj if (nidx > 0) then - prc = psb_get_mpi_rank(ictxt,adj(j)) + prc = psb_get_mpi_rank(ctxt,adj(j)) p2ptag = psb_long_swap_tag !write(0,*) me, ' First send to ',adj(j),nidx, prc call mpi_send(idx,nidx,& @@ -323,7 +324,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) do j=1, nadj !write(0,*) me, ' First send to ',adj(j),nidx if (nidx > 0) then - prc = psb_get_mpi_rank(ictxt,adj(j)) + prc = psb_get_mpi_rank(ctxt,adj(j)) p2ptag = psb_int_swap_tag !write(0,*) me, ' Posting second receive from ',adj(j),nidx, prc call mpi_irecv(lclidx((j-1)*nidx+1),nidx, & @@ -337,7 +338,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) ! do i = 0, np-1 if (rvsz(i)>0) then - prc = psb_get_mpi_rank(ictxt,i) + prc = psb_get_mpi_rank(ctxt,i) p2ptag = psb_int_swap_tag !write(0,*) me, ' Second send to ',i,rvsz(i), prc call mpi_send(tproc(hidx(i)+1),rvsz(i),& @@ -388,12 +389,12 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) end if do j=1, nadj !write(0,*) me, ' First send to ',adj(j),nidx - if (nidx > 0) call psb_snd(ictxt,idx(1:nidx),adj(j)) + if (nidx > 0) call psb_snd(ctxt,idx(1:nidx),adj(j)) end do do i = 0, np-1 if (rvsz(i)>0) then ! write(0,*) me, ' First receive from ',i,rvsz(i) - call psb_rcv(ictxt,rmtidx(hidx(i)+1:hidx(i)+rvsz(i)),i) + call psb_rcv(ctxt,rmtidx(hidx(i)+1:hidx(i)+rvsz(i)),i) end if end do @@ -412,7 +413,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) do i = 0, np-1 if (rvsz(i)>0) then !write(0,*) me, ' Second send to ',i,rvsz(i) - call psb_snd(ictxt,tproc(hidx(i)+1:hidx(i)+rvsz(i)),i) + call psb_snd(ctxt,tproc(hidx(i)+1:hidx(i)+rvsz(i)),i) end if end do ! @@ -421,7 +422,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) ! do j = 1, nadj !write(0,*) me, ' Second receive from ',adj(j), nidx - if (nidx > 0) call psb_rcv(ictxt,tproc(1:nidx),adj(j)) + if (nidx > 0) call psb_rcv(ctxt,tproc(1:nidx),adj(j)) iprc(1:nidx) = max(iprc(1:nidx), tproc(1:nidx)) end do case default @@ -433,7 +434,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_bld_glb_dep_list.F90 b/base/internals/psi_bld_glb_dep_list.F90 index bf28e49b..f43e5f17 100644 --- a/base/internals/psi_bld_glb_dep_list.F90 +++ b/base/internals/psi_bld_glb_dep_list.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_i_bld_glb_dep_list(ictxt,loc_dl,length_dl,dep_list,dl_lda,info) +subroutine psi_i_bld_glb_dep_list(ctxt,loc_dl,length_dl,c_dep_list,dl_ptr,info) use psi_mod, psb_protect_name => psi_i_bld_glb_dep_list #ifdef MPI_MOD use mpi @@ -44,96 +44,7 @@ subroutine psi_i_bld_glb_dep_list(ictxt,loc_dl,length_dl,dep_list,dl_lda,info) include 'mpif.h' #endif ! ....scalar parameters... - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dl_lda - integer(psb_ipk_), intent(in) :: loc_dl(:), length_dl(0:) - integer(psb_ipk_), allocatable, intent(out) :: dep_list(:,:) - integer(psb_ipk_), intent(out) :: info - - - ! .....local arrays.... - integer(psb_ipk_) :: int_err(5) - - ! .....local scalars... - integer(psb_ipk_) :: i, proc,j,err_act - integer(psb_ipk_) :: err - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpk_) :: iictxt, icomm, me, np, minfo - logical, parameter :: dist_symm_list=.false., print_dl=.false. - character name*20 - name='psi_bld_glb_dep_list' - - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - iictxt = ictxt - info = psb_success_ - - call psb_info(iictxt,me,np) - - - dl_lda = length_dl(me) - call psb_max(iictxt, dl_lda) - - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),': Dep_list length ',length_dl(me),dl_lda - dl_lda = max(dl_lda,1) - allocate(dep_list(dl_lda,0:np),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - icomm = psb_get_mpi_comm(iictxt) - call mpi_allgather(loc_dl,dl_lda,psb_mpi_ipk_,& - & dep_list,dl_lda,psb_mpi_ipk_,icomm,minfo) - - info = minfo - if (info /= psb_success_) then - info=psb_err_internal_error_ - goto 9999 - endif - if (print_dl) then - if (me == 0) then - write(0,*) ' Dep_list ' - do i=0,np-1 - j = length_dl(i) - write(0,*) 'Proc ',i,':',dep_list(1:j,i) - end do - flush(0) - end if - call psb_barrier(ictxt) - end if - - call psb_erractionrestore(err_act) - return - - -9999 continue - - call psb_errpush(info,name,i_err=int_err) - call psb_error_handler(err_act) - - return - -end subroutine psi_i_bld_glb_dep_list - -subroutine psi_i_bld_glb_csr_dep_list(ictxt,loc_dl,length_dl,c_dep_list,dl_ptr,info) - use psi_mod, psb_protect_name => psi_i_bld_glb_csr_dep_list -#ifdef MPI_MOD - use mpi -#endif - use psb_penv_mod - use psb_const_mod - use psb_error_mod - use psb_desc_mod - use psb_sort_mod - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - ! ....scalar parameters... - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: loc_dl(:), length_dl(0:) integer(psb_ipk_), allocatable, intent(out) :: c_dep_list(:), dl_ptr(:) integer(psb_ipk_), intent(out) :: info @@ -146,7 +57,8 @@ subroutine psi_i_bld_glb_csr_dep_list(ictxt,loc_dl,length_dl,c_dep_list,dl_ptr,i integer(psb_ipk_) :: i, proc,j,err_act, length, myld integer(psb_ipk_) :: err integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpk_) :: iictxt, icomm, me, np, minfo + integer(psb_ipk_) :: me, np + integer(psb_mpk_) :: icomm, minfo logical, parameter :: dist_symm_list=.false., print_dl=.false. character name*20 name='psi_bld_glb_csr_dep_list' @@ -155,10 +67,9 @@ subroutine psi_i_bld_glb_csr_dep_list(ictxt,loc_dl,length_dl,c_dep_list,dl_ptr,i debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - iictxt = ictxt info = psb_success_ - call psb_info(iictxt,me,np) + call psb_info(ctxt,me,np) myld = length_dl(me) length = sum(length_dl(0:np-1)) @@ -180,7 +91,7 @@ subroutine psi_i_bld_glb_csr_dep_list(ictxt,loc_dl,length_dl,c_dep_list,dl_ptr,i call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if - icomm = psb_get_mpi_comm(iictxt) + icomm = psb_get_mpi_comm(ctxt) call mpi_allgatherv(loc_dl,myld,psb_mpi_ipk_,& & c_dep_list,length_dl,dl_ptr,psb_mpi_ipk_,icomm,minfo) @@ -198,7 +109,7 @@ subroutine psi_i_bld_glb_csr_dep_list(ictxt,loc_dl,length_dl,c_dep_list,dl_ptr,i end do flush(0) end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_erractionrestore(err_act) @@ -212,4 +123,4 @@ subroutine psi_i_bld_glb_csr_dep_list(ictxt,loc_dl,length_dl,c_dep_list,dl_ptr,i return -end subroutine psi_i_bld_glb_csr_dep_list +end subroutine psi_i_bld_glb_dep_list diff --git a/base/internals/psi_bld_tmphalo.f90 b/base/internals/psi_bld_tmphalo.f90 index dc13b7c2..78ce69ed 100644 --- a/base/internals/psi_bld_tmphalo.f90 +++ b/base/internals/psi_bld_tmphalo.f90 @@ -62,20 +62,21 @@ subroutine psi_bld_tmphalo(desc,info) integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,& & n_col, err_act, key, ih, nh, idx, nk,icomm - integer(psb_ipk_) :: ictxt,n_row + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: n_row character(len=20) :: name,ch_err info = psb_success_ name = 'psi_bld_tmphalo' call psb_erractionsave(err_act) - ictxt = desc%get_context() + ctxt = desc%get_context() icomm = desc%get_mpic() n_row = desc%get_local_rows() n_col = desc%get_local_cols() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -144,7 +145,7 @@ subroutine psi_bld_tmphalo(desc,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_bld_tmpovrl.f90 b/base/internals/psi_bld_tmpovrl.f90 index 671a20d3..e34b6463 100644 --- a/base/internals/psi_bld_tmpovrl.f90 +++ b/base/internals/psi_bld_tmpovrl.f90 @@ -68,8 +68,8 @@ subroutine psi_i_bld_tmpovrl(iv,desc,info) & l_ov_ix,l_ov_el, err_act, itmpov, k, glx, icomm integer(psb_ipk_) :: idx integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:) - - integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: n_row, debug_unit, debug_level character(len=20) :: name,ch_err info = psb_success_ @@ -77,11 +77,11 @@ subroutine psi_i_bld_tmpovrl(iv,desc,info) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc%get_context() + ctxt = desc%get_context() icomm = desc%get_mpic() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -144,7 +144,7 @@ subroutine psi_i_bld_tmpovrl(iv,desc,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_compute_size.f90 b/base/internals/psi_compute_size.f90 index 36d52f43..1820cfec 100644 --- a/base/internals/psi_compute_size.f90 +++ b/base/internals/psi_compute_size.f90 @@ -47,7 +47,8 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) integer(psb_ipk_) :: desc_data(:), index_in(:) ! ....local scalars.... integer(psb_ipk_) :: i,np,me,proc, max_index - integer(psb_ipk_) :: ictxt, err_act + integer(psb_ipk_) :: err_act + type(psb_ctxt_type) :: ctxt ! ...local array... integer(psb_ipk_) :: int_err(5) integer(psb_ipk_), allocatable :: counter_recv(:), counter_dl(:) @@ -62,9 +63,9 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) debug_level = psb_get_debug_level() info = psb_success_ - ictxt = desc_data(psb_ctxt_) + ctxt = desc_data(psb_ctxt_) - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -114,7 +115,7 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) enddo ! computing max global value of dl_lda - call psb_amx(ictxt, dl_lda) + call psb_amx(ctxt, dl_lda) if (debug_level>=psb_debug_inner_) then write(debug_unit,*) me,' ',trim(name),': ',dl_lda @@ -123,7 +124,7 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_crea_index.f90 b/base/internals/psi_crea_index.f90 index 68bcbd20..a2021e2e 100644 --- a/base/internals/psi_crea_index.f90 +++ b/base/internals/psi_crea_index.f90 @@ -64,9 +64,11 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) integer(psb_ipk_), allocatable, intent(inout) :: index_out(:) ! ....local scalars... - integer(psb_ipk_) :: ictxt, me, np, mode, err_act, dl_lda, ldl + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, mode, err_act, dl_lda, ldl ! ...parameters... - integer(psb_ipk_), allocatable :: dep_list(:,:), length_dl(:), loc_dl(:), c_dep_list(:), dl_ptr(:) + integer(psb_ipk_), allocatable :: length_dl(:), loc_dl(:),& + & c_dep_list(:), dl_ptr(:) integer(psb_ipk_) :: dlmax, dlavg integer(psb_ipk_),parameter :: root=psb_root_,no_comm=-1 integer(psb_ipk_) :: debug_level, debug_unit @@ -81,9 +83,9 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_ctxt() + ctxt = desc_a%get_ctxt() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -110,7 +112,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) mode = 1 if (do_timings) call psb_tic(idx_phase1) - call psi_extract_loc_dl(ictxt,& + call psi_extract_loc_dl(ctxt,& & desc_a%is_bld(), desc_a%is_upd(),& & index_in, loc_dl,length_dl,info) @@ -124,7 +126,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) if (choose_sorting(dlmax,dlavg,np)) then if (do_timings) call psb_tic(idx_phase21) - call psi_bld_glb_dep_list(ictxt,& + call psi_bld_glb_dep_list(ctxt,& & loc_dl,length_dl,c_dep_list,dl_ptr,info) if (info /= 0) then write(0,*) me,trim(name),' From bld_glb_list ',info @@ -134,7 +136,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) !!$ ! ....now i can sort dependency lists. if (do_timings) call psb_toc(idx_phase21) if (do_timings) call psb_tic(idx_phase22) - call psi_sort_dl(dl_ptr,c_dep_list,length_dl,ictxt,info) + call psi_sort_dl(dl_ptr,c_dep_list,length_dl,ctxt,info) if (info /= 0) then write(0,*) me,trim(name),' From sort_dl ',info end if @@ -189,8 +191,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) end if if (do_timings) call psb_toc(idx_phase3) - if (allocated(dep_list)) deallocate(dep_list,stat=info) - if ((info==0).and.allocated(length_dl)) deallocate(length_dl,stat=info) + if (allocated(length_dl)) deallocate(length_dl,stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 @@ -201,7 +202,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return contains diff --git a/base/internals/psi_crea_ovr_elem.f90 b/base/internals/psi_crea_ovr_elem.f90 index 359c264c..bf9eeee4 100644 --- a/base/internals/psi_crea_ovr_elem.f90 +++ b/base/internals/psi_crea_ovr_elem.f90 @@ -63,7 +63,6 @@ subroutine psi_i_crea_ovr_elem(me,desc_overlap,ovr_elem,info) integer(psb_ipk_) :: nel, ip, ix, iel, insize, err_act, iproc integer(psb_ipk_), allocatable :: telem(:,:) - character(len=20) :: name diff --git a/base/internals/psi_desc_impl.f90 b/base/internals/psi_desc_impl.f90 index 43eae7bb..4ba6f40a 100644 --- a/base/internals/psi_desc_impl.f90 +++ b/base/internals/psi_desc_impl.f90 @@ -74,8 +74,9 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) class(psb_i_base_vect_type), optional, intent(in) :: mold ! ....local scalars.... - integer(psb_ipk_) :: np,me - integer(psb_ipk_) :: ictxt, err_act,nxch,nsnd,nrcv,j,k + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: err_act,nxch,nsnd,nrcv,j,k ! ...local array... integer(psb_ipk_), allocatable :: idx_out(:), tmp_mst_idx(:) @@ -93,9 +94,9 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) debug_unit = psb_get_debug_unit() info = psb_success_ - ictxt = cdesc%get_context() + ctxt = cdesc%get_context() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -210,7 +211,7 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_desc_index.F90 b/base/internals/psi_desc_index.F90 index ecf7f2f3..6dc78a79 100644 --- a/base/internals/psi_desc_index.F90 +++ b/base/internals/psi_desc_index.F90 @@ -121,7 +121,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& ! ....local scalars... integer(psb_ipk_) :: j,me,np,i,proc ! ...parameters... - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_), parameter :: no_comm=-1 ! ...local arrays.. integer(psb_lpk_),allocatable :: sndbuf(:), rcvbuf(:) @@ -149,9 +149,9 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc%get_context() + ctxt = desc%get_context() icomm = desc%get_mpic() - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -160,7 +160,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& if (debug_level >= psb_debug_inner_) then write(debug_unit,*) me,' ',trim(name),': start' - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif if ((do_timings).and.(idx_phase1==-1)) & & idx_phase1 = psb_get_timer_idx("I_DSC_IDX: phase1 ") @@ -226,7 +226,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& end if if (debug_level >= psb_debug_inner_) then write(debug_unit,*) me,' ',trim(name),': computed sizes ',iszr,iszs - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif ntot = (3*(count((sdsz>0).or.(rvsz>0)))+ iszs + iszr) + 1 @@ -243,7 +243,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& if (debug_level >= psb_debug_inner_) then write(debug_unit,*) me,' ',trim(name),': computed allocated workspace ',iszr,iszs - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) if(info /= psb_success_) then @@ -285,7 +285,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& if (debug_level >= psb_debug_inner_) then write(debug_unit,*) me,' ',trim(name),': prepared send buffer ' - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif ! ! now have to regenerate bsdindx @@ -316,7 +316,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& ixp = 1 do i=1, length_dl proc = dep_list(i) - prcid(ixp) = psb_get_mpi_rank(ictxt,proc) + prcid(ixp) = psb_get_mpi_rank(ctxt,proc) sz = rvsz(proc+1) if (sz > 0) then p2ptag = psb_long_tag @@ -330,7 +330,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& ixp = 1 do i=1, length_dl proc = dep_list(i) - prcid(ixp) = psb_get_mpi_rank(ictxt,proc) + prcid(ixp) = psb_get_mpi_rank(ctxt,proc) sz = sdsz(proc+1) if (sz > 0) then p2ptag = psb_long_tag @@ -344,7 +344,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& ixp = 1 do i=1, length_dl proc = dep_list(i) - prcid(ixp) = psb_get_mpi_rank(ictxt,proc) + prcid(ixp) = psb_get_mpi_rank(ctxt,proc) sz = rvsz(proc+1) if (sz > 0) then call mpi_wait(rvhd(ixp),p2pstat,iret) @@ -358,7 +358,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& sz = sdsz(proc+1) idx = bsdindx(proc+1) if (sz > 0) then - call psb_snd(ictxt,sndbuf(idx+1:idx+sz), proc) + call psb_snd(ctxt,sndbuf(idx+1:idx+sz), proc) end if end do @@ -367,7 +367,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& sz = rvsz(proc+1) idx = brvindx(proc+1) if (sz > 0) then - call psb_rcv(ictxt,rcvbuf(idx+1:idx+sz),proc) + call psb_rcv(ctxt,rcvbuf(idx+1:idx+sz),proc) end if end do @@ -407,13 +407,13 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,& if (do_timings) call psb_toc(idx_phase4) if (debug_level >= psb_debug_inner_) then write(debug_unit,*) me,' ',trim(name),': done' - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_extrct_dl.F90 b/base/internals/psi_extrct_dl.F90 index 1b5280f8..60cf75d1 100644 --- a/base/internals/psi_extrct_dl.F90 +++ b/base/internals/psi_extrct_dl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& +subroutine psi_i_extract_dep_list(ctxt,is_bld,is_upd,desc_str,dep_list,& & length_dl,dl_lda,mode,info) ! internal routine @@ -133,10 +133,11 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& include 'mpif.h' #endif ! ....scalar parameters... - logical, intent(in) :: is_bld, is_upd - integer(psb_ipk_), intent(in) :: ictxt,mode - integer(psb_ipk_), intent(out) :: dl_lda - integer(psb_ipk_), intent(in) :: desc_str(*) + logical, intent(in) :: is_bld, is_upd + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: mode + integer(psb_ipk_), intent(out) :: dl_lda + integer(psb_ipk_), intent(in) :: desc_str(*) integer(psb_ipk_), allocatable, intent(out) :: dep_list(:,:),length_dl(:) integer(psb_ipk_), intent(out) :: info ! .....local arrays.... @@ -147,7 +148,8 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& integer(psb_ipk_) :: i,pointer_dep_list,proc,j,err_act integer(psb_ipk_) :: err integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpk_) :: iictxt, icomm, me, np, minfo + integer(psb_ipk_) :: me, np + integer(psb_mpk_) :: icomm, minfo logical, parameter :: dist_symm_list=.false., print_dl=.false., profile=.true. logical, parameter :: do_timings=.false. integer(psb_ipk_), save :: idx_phase1=-1, idx_phase2=-1, idx_phase3=-1 @@ -157,7 +159,6 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - iictxt = ictxt info = psb_success_ if ((do_timings).and.(idx_phase1==-1)) & & idx_phase1 = psb_get_timer_idx("PSI_XTR_DL: phase1 ") @@ -166,7 +167,7 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& !!$ if ((do_timings).and.(idx_phase3==-1)) & !!$ & idx_phase3 = psb_get_timer_idx("PSI_XTR_DL: phase3") - call psb_info(iictxt,me,np) + call psb_info(ctxt,me,np) if (do_timings) call psb_tic(idx_phase1) allocate(itmp(2*np+1),length_dl(0:np),stat=info) @@ -268,9 +269,9 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& if (do_timings) call psb_tic(idx_phase2) if (dist_symm_list) then call psb_realloc(length_dl(me),itmp,info) - call psi_symm_dep_list(itmp,ictxt,info) + call psi_symm_dep_list(itmp,ctxt,info) dl_lda = max(size(itmp),1) - call psb_max(iictxt, dl_lda) + call psb_max(ctxt, dl_lda) if (debug_level >= psb_debug_inner_) & & write(debug_unit,*) me,' ',trim(name),': Dep_list length ',length_dl(me),dl_lda @@ -282,8 +283,8 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& goto 9999 end if - call psb_sum(iictxt,length_dl(0:np)) - icomm = psb_get_mpi_comm(iictxt) + call psb_sum(ctxt,length_dl(0:np)) + icomm = psb_get_mpi_comm(ctxt) call mpi_allgather(itmp,dl_lda,psb_mpi_ipk_,& & dep_list,dl_lda,psb_mpi_ipk_,icomm,minfo) info = minfo @@ -298,7 +299,7 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& integer(psb_ipk_) :: i,j,ip,dlsym, ldu, mdl, l1, l2 dl_lda = max(length_dl(me),1) - call psb_max(iictxt, dl_lda) + call psb_max(ctxt, dl_lda) if (debug_level >= psb_debug_inner_) & & write(debug_unit,*) me,' ',trim(name),': Dep_list length ',length_dl(me),dl_lda allocate(dep_list(dl_lda,0:np),stat=info) @@ -306,8 +307,8 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if - call psb_sum(iictxt,length_dl(0:np)) - icomm = psb_get_mpi_comm(iictxt) + call psb_sum(ctxt,length_dl(0:np)) + icomm = psb_get_mpi_comm(ctxt) call mpi_allgather(itmp,dl_lda,psb_mpi_ipk_,& & dep_list,dl_lda,psb_mpi_ipk_,icomm,minfo) info = minfo @@ -379,7 +380,7 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& end do flush(0) end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if if (do_timings) call psb_toc(idx_phase2) if ((profile).and.(me==0)) then diff --git a/base/internals/psi_fnd_owner.F90 b/base/internals/psi_fnd_owner.F90 index f2a22e0e..7f111a03 100644 --- a/base/internals/psi_fnd_owner.F90 +++ b/base/internals/psi_fnd_owner.F90 @@ -74,7 +74,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,& & last_ih, last_j - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: gettime=.false. real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx character(len=20) :: name @@ -83,14 +84,14 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) name = 'psi_fnd_owner' call psb_erractionsave(err_act) - ictxt = desc%get_context() + ctxt = desc%get_context() icomm = desc%get_mpic() n_row = desc%get_local_rows() n_col = desc%get_local_cols() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -118,7 +119,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_graph_fnd_owner.F90 b/base/internals/psi_graph_fnd_owner.F90 index 485c4806..e507d020 100644 --- a/base/internals/psi_graph_fnd_owner.F90 +++ b/base/internals/psi_graph_fnd_owner.F90 @@ -99,12 +99,13 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) integer(psb_lpk_), allocatable :: tidx(:) integer(psb_ipk_), allocatable :: tprc(:), tsmpl(:), ladj(:) - integer(psb_mpk_) :: icomm, minfo, iictxt + integer(psb_mpk_) :: icomm, minfo integer(psb_ipk_) :: i,n_row,n_col,err_act,ip,j,ipnt, nsampl_out,& & nv, n_answers, nqries, nsampl_in, locr_max, & & nqries_max, nadj, maxspace, mxnsin integer(psb_lpk_) :: mglob, ih - integer(psb_ipk_) :: ictxt,np,me, nresp + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, nresp integer(psb_ipk_), parameter :: nt=4 integer(psb_ipk_) :: tmpv(4) logical, parameter :: do_timings=.false., trace=.false., debugsz=.false. @@ -116,12 +117,12 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) name = 'psi_graph_fnd_owner' call psb_erractionsave(err_act) - ictxt = idxmap%get_ctxt() + ctxt = idxmap%get_ctxt() icomm = idxmap%get_mpic() mglob = idxmap%get_gr() n_row = idxmap%get_lr() n_col = idxmap%get_lc() - iictxt = ictxt + if ((do_timings).and.(idx_sweep0==-1)) & & idx_sweep0 = psb_get_timer_idx("GRPH_FND_OWN: Outer sweep") if ((do_timings).and.(idx_loop_a2a==-1)) & @@ -130,7 +131,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) & idx_loop_neigh = psb_get_timer_idx("GRPH_FND_OWN: Loop neigh") - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -179,7 +180,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) tmpv(2) = nqries_max tmpv(3) = n_row tmpv(4) = psb_cd_get_maxspace() - call psb_max(ictxt,tmpv) + call psb_max(ctxt,tmpv) nqries_max = tmpv(2) locr_max = tmpv(3) maxspace = nt*locr_max @@ -198,7 +199,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) call idxmap%xtnd_p_adjcncy(ladj) nqries = nv - n_answers nqries_max = nqries - call psb_max(ictxt,nqries_max) + call psb_max(ctxt,nqries_max) if (trace.and.(me == 0)) write(0,*) ' After initial sweep:',nqries_max if (debugsz) write(0,*) me,' After sweep on user-defined topology',nqries_max end if @@ -262,14 +263,14 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) !!$ write(0,*) me,' After a2a ',nqries nsampl_in = min(nqries,max(1,(maxspace+max(1,nadj)-1))/(max(1,nadj))) mxnsin = nsampl_in - call psb_max(ictxt,mxnsin) + call psb_max(ctxt,mxnsin) !!$ write(0,*) me, ' mxnsin ',mxnsin if (mxnsin>0) call psi_adj_fnd_sweep(idx,iprc,ladj,idxmap,nsampl_in,n_answers) call idxmap%xtnd_p_adjcncy(ladj) nqries = nv - n_answers nqries_max = nqries - call psb_max(ictxt,nqries_max) + call psb_max(ctxt,nqries_max) if (trace.and.(me == 0)) write(0,*) ' fnd_owner_loop remaining:',nqries_max if (do_timings) call psb_toc(idx_loop_neigh) end do fnd_owner_loop @@ -277,7 +278,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -360,12 +361,13 @@ contains integer(psb_ipk_), intent(in) :: adj(:) class(psb_indx_map), intent(inout) :: idxmap ! - integer(psb_ipk_) :: ipnt, ns_in, ns_out, n_rem, ictxt, me, np, isw + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: ipnt, ns_in, ns_out, n_rem, me, np, isw integer(psb_lpk_), allocatable :: tidx(:) integer(psb_ipk_), allocatable :: tsmpl(:) - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,me,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,me,np) call psb_realloc(n_samples,tidx,info) call psb_realloc(n_samples,tsmpl,info) ipnt = 1 @@ -380,7 +382,7 @@ contains !write(0,*) me,' Sweep ',isw,' answers:',ns_out n_answers = n_answers + ns_out n_rem = size(idx)-ipnt - call psb_max(ictxt,n_rem) + call psb_max(ctxt,n_rem) !write(0,*) me,' Sweep ',isw,n_rem, ipnt, n_samples if (n_rem <= 0) exit isw = isw + 1 diff --git a/base/internals/psi_indx_map_fnd_owner.F90 b/base/internals/psi_indx_map_fnd_owner.F90 index 25f900f0..0ecade3d 100644 --- a/base/internals/psi_indx_map_fnd_owner.F90 +++ b/base/internals/psi_indx_map_fnd_owner.F90 @@ -73,11 +73,12 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info) integer(psb_ipk_), allocatable :: hhidx(:) - integer(psb_mpk_) :: icomm, minfo, iictxt + integer(psb_mpk_) :: icomm, minfo integer(psb_ipk_) :: i, err_act, hsize integer(psb_lpk_) :: nv integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me, nresp + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, nresp logical, parameter :: gettime=.false. real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx character(len=20) :: name @@ -86,12 +87,11 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info) name = 'psb_indx_map_fnd_owner' call psb_erractionsave(err_act) - ictxt = idxmap%get_ctxt() + ctxt = idxmap%get_ctxt() icomm = idxmap%get_mpic() mglob = idxmap%get_gr() - iictxt = ictxt - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -205,12 +205,12 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info) end if if (gettime) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() t1 = t1 -t0 - tamx - tidx - call psb_amx(ictxt,tamx) - call psb_amx(ictxt,tidx) - call psb_amx(ictxt,t1) + call psb_amx(ctxt,tamx) + call psb_amx(ctxt,tidx) + call psb_amx(ctxt,t1) if (me == psb_root_) then write(psb_out_unit,'(" fnd_owner idx time : ",es10.4)') tidx write(psb_out_unit,'(" fnd_owner amx time : ",es10.4)') tamx @@ -221,7 +221,7 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_sort_dl.f90 b/base/internals/psi_sort_dl.f90 index c4e3ea07..55cc280f 100644 --- a/base/internals/psi_sort_dl.f90 +++ b/base/internals/psi_sort_dl.f90 @@ -77,7 +77,7 @@ ! node in the dependency list for the current one * ! * !********************************************************************** -subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ictxt,info) +subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ctxt,info) use psi_mod, psb_protect_name => psi_i_csr_sort_dl use psb_const_mod use psb_error_mod @@ -85,8 +85,8 @@ subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ictxt,info) implicit none integer(psb_ipk_), intent(inout) :: c_dep_list(:), dl_ptr(0:), l_dep_list(0:) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_), allocatable :: dg(:), dgp(:),& & idx(:), upd(:), edges(:,:), ich(:) @@ -96,7 +96,7 @@ subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ictxt,info) integer(psb_ipk_) :: me, np info = 0 - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) nedges = size(c_dep_list) allocate(dg(0:np-1),dgp(nedges),edges(2,nedges),upd(0:np-1),& diff --git a/base/internals/psi_symm_dep_list.F90 b/base/internals/psi_symm_dep_list.F90 index cd2894c1..728ee832 100644 --- a/base/internals/psi_symm_dep_list.F90 +++ b/base/internals/psi_symm_dep_list.F90 @@ -37,7 +37,7 @@ ! ! Arguments: ! -subroutine psi_symm_dep_list_inrv(rvsz,adj,ictxt,info) +subroutine psi_symm_dep_list_inrv(rvsz,adj,ctxt,info) use psb_serial_mod use psb_const_mod use psb_error_mod @@ -54,8 +54,8 @@ subroutine psi_symm_dep_list_inrv(rvsz,adj,ictxt,info) #endif integer(psb_mpk_), intent(inout) :: rvsz(0:) integer(psb_ipk_), allocatable, intent(inout) :: adj(:) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(out) :: info ! integer(psb_ipk_), allocatable :: ladj(:) @@ -70,15 +70,13 @@ subroutine psi_symm_dep_list_inrv(rvsz,adj,ictxt,info) name = 'psi_symm_dep_list' call psb_erractionsave(err_act) - icomm = psb_get_mpi_comm(ictxt) - - call psb_info(ictxt, me, np) - + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif + icomm = psb_get_mpi_comm(ctxt) nadj = size(adj) @@ -112,13 +110,13 @@ subroutine psi_symm_dep_list_inrv(rvsz,adj,ictxt,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psi_symm_dep_list_inrv -subroutine psi_symm_dep_list_norv(adj,ictxt,info) +subroutine psi_symm_dep_list_norv(adj,ctxt,info) use psb_serial_mod use psb_const_mod use psb_error_mod @@ -134,8 +132,8 @@ subroutine psi_symm_dep_list_norv(adj,ictxt,info) include 'mpif.h' #endif integer(psb_ipk_), allocatable, intent(inout) :: adj(:) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(out) :: info ! integer(psb_mpk_), allocatable :: rvsz(:), sdsz(:) @@ -144,22 +142,21 @@ subroutine psi_symm_dep_list_norv(adj,ictxt,info) integer(psb_ipk_) :: i,n_row,n_col,err_act,hsize,ip,& & last_ih, last_j, nidx, nrecv, nadj integer(psb_ipk_) :: mglob, ih - integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: np, me character(len=20) :: name info = psb_success_ name = 'psi_symm_dep_list' call psb_erractionsave(err_act) - icomm = psb_get_mpi_comm(ictxt) - - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif + icomm = psb_get_mpi_comm(ctxt) nadj = size(adj) @@ -177,7 +174,7 @@ subroutine psi_symm_dep_list_norv(adj,ictxt,info) call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& & rvsz,1,psb_mpi_mpk_,icomm,minfo) - if (minfo == 0) call psi_symm_dep_list(rvsz,adj,ictxt,info) + if (minfo == 0) call psi_symm_dep_list(rvsz,adj,ctxt,info) if ((minfo /=0).or.(info /= 0)) then call psb_errpush(psb_err_from_subroutine_,name,a_err='inner call symm_dep') goto 9999 @@ -186,7 +183,7 @@ subroutine psi_symm_dep_list_norv(adj,ictxt,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/internals/psi_xtr_loc_dl.F90 b/base/internals/psi_xtr_loc_dl.F90 index c97cc7a5..8275add9 100644 --- a/base/internals/psi_xtr_loc_dl.F90 +++ b/base/internals/psi_xtr_loc_dl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) +subroutine psi_i_xtr_loc_dl(ctxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) ! internal routine ! == = ============= @@ -122,11 +122,11 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) include 'mpif.h' #endif ! ....scalar parameters... - logical, intent(in) :: is_bld, is_upd - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: desc_str(:) + logical, intent(in) :: is_bld, is_upd + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: desc_str(:) integer(psb_ipk_), allocatable, intent(out) :: loc_dl(:), length_dl(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info ! .....local arrays.... integer(psb_ipk_) :: int_err(5) @@ -134,7 +134,7 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) integer(psb_ipk_) :: i,pdl,proc,j,err_act, ldu integer(psb_ipk_) :: err integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpk_) :: iictxt, icomm, me, np, minfo + integer(psb_ipk_) :: me, np logical, parameter :: dist_symm_list=.true., print_dl=.false., profile=.true. character name*20 name='psi_extrct_dl' @@ -142,10 +142,9 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - iictxt = ictxt info = psb_success_ - call psb_info(iictxt,me,np) + call psb_info(ctxt,me,np) pdl = size(desc_str) allocate(loc_dl(pdl+1),length_dl(0:np),stat=info) if (info /= psb_success_) then @@ -210,11 +209,11 @@ subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) call psb_msort_unique(loc_dl(1:pdl),ldu) pdl = ldu call psb_realloc(pdl,loc_dl,info) - call psi_symm_dep_list(loc_dl,ictxt,info) + call psi_symm_dep_list(loc_dl,ctxt,info) pdl = size(loc_dl) length_dl = 0 length_dl(me) = pdl - call psb_sum(ictxt,length_dl) + call psb_sum(ctxt,length_dl) call psb_erractionrestore(err_act) return diff --git a/base/modules/Makefile b/base/modules/Makefile index 6c19b247..31c509ad 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -1,6 +1,7 @@ include ../../Make.inc BASIC_MODS= psb_const_mod.o psb_cbind_const_mod.o psb_error_mod.o psb_realloc_mod.o \ + auxil/psb_string_mod.o \ auxil/psb_m_realloc_mod.o \ auxil/psb_e_realloc_mod.o \ auxil/psb_s_realloc_mod.o \ @@ -8,8 +9,8 @@ BASIC_MODS= psb_const_mod.o psb_cbind_const_mod.o psb_error_mod.o psb_realloc_mo auxil/psb_c_realloc_mod.o \ auxil/psb_z_realloc_mod.o -COMMINT=penv/psi_comm_buffers_mod.o penv/psi_penv_mod.o \ - penv/psi_p2p_mod.o penv/psi_m_p2p_mod.o \ +COMMINT= penv/psi_penv_mod.o \ + penv/psi_p2p_mod.o penv/psi_m_p2p_mod.o \ penv/psi_e_p2p_mod.o \ penv/psi_s_p2p_mod.o \ penv/psi_d_p2p_mod.o \ @@ -23,38 +24,9 @@ COMMINT=penv/psi_comm_buffers_mod.o penv/psi_penv_mod.o \ penv/psi_c_collective_mod.o \ penv/psi_z_collective_mod.o -UTIL_MODS = auxil/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ - desc/psb_gen_block_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o\ - desc/psb_glist_map_mod.o desc/psb_hash_map_mod.o desc/psb_hashval.o \ - desc/psb_desc_mod.o auxil/psb_sort_mod.o \ - serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ +SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o \ serial/psb_serial_mod.o \ - tools/psb_cd_tools_mod.o \ - tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ - tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ - tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ - tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ - tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ - tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o \ - tools/psb_tools_mod.o \ - psb_penv_mod.o $(COMMINT) psb_error_impl.o psb_timers_mod.o \ - comm/psb_base_linmap_mod.o comm/psb_linmap_mod.o \ - comm/psb_s_linmap_mod.o comm/psb_d_linmap_mod.o \ - comm/psb_c_linmap_mod.o comm/psb_z_linmap_mod.o \ - comm/psb_comm_mod.o \ - comm/psb_i_comm_mod.o comm/psb_l_comm_mod.o \ - comm/psb_s_comm_mod.o comm/psb_d_comm_mod.o\ - comm/psb_c_comm_mod.o comm/psb_z_comm_mod.o \ - comm/psb_m_comm_a_mod.o comm/psb_e_comm_a_mod.o \ - comm/psb_s_comm_a_mod.o comm/psb_d_comm_a_mod.o\ - comm/psb_c_comm_a_mod.o comm/psb_z_comm_a_mod.o \ - comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o \ - comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \ - comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o \ - comm/psi_i_comm_v_mod.o comm/psi_l_comm_v_mod.o \ - comm/psi_s_comm_v_mod.o comm/psi_d_comm_v_mod.o \ - comm/psi_c_comm_v_mod.o comm/psi_z_comm_v_mod.o \ serial/psb_i_base_vect_mod.o serial/psb_i_vect_mod.o\ serial/psb_l_base_vect_mod.o serial/psb_l_vect_mod.o\ serial/psb_d_base_vect_mod.o serial/psb_d_vect_mod.o\ @@ -62,9 +34,6 @@ UTIL_MODS = auxil/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_m serial/psb_c_base_vect_mod.o serial/psb_c_vect_mod.o\ serial/psb_z_base_vect_mod.o serial/psb_z_vect_mod.o\ serial/psb_vect_mod.o\ - psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o \ - psblas/psb_d_psblas_mod.o psblas/psb_z_psblas_mod.o \ - psblas/psb_psblas_mod.o \ auxil/psi_serial_mod.o auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o \ auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o \ @@ -91,7 +60,6 @@ UTIL_MODS = auxil/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_m auxil/psb_d_hsort_x_mod.o \ auxil/psb_c_hsort_x_mod.o \ auxil/psb_z_hsort_x_mod.o \ - psb_check_mod.o desc/psb_hash_mod.o\ serial/psb_base_mat_mod.o serial/psb_mat_mod.o\ serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_mat_mod.o \ serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_mat_mod.o \ @@ -102,9 +70,43 @@ UTIL_MODS = auxil/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_m #\ # serial/psb_ld_base_mat_mod.o serial/psb_lbase_mat_mod.o serial/psb_ld_csc_mat_mod.o serial/psb_ld_csr_mat_mod.o +UTIL_MODS = desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ + desc/psb_gen_block_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o\ + desc/psb_glist_map_mod.o desc/psb_hash_map_mod.o desc/psb_hashval.o \ + desc/psb_desc_mod.o auxil/psb_sort_mod.o \ + tools/psb_cd_tools_mod.o \ + tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ + tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ + tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ + tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ + tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ + tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o \ + tools/psb_tools_mod.o \ + psb_penv_mod.o $(COMMINT) psb_error_impl.o psb_timers_mod.o \ + comm/psb_base_linmap_mod.o comm/psb_linmap_mod.o \ + comm/psb_s_linmap_mod.o comm/psb_d_linmap_mod.o \ + comm/psb_c_linmap_mod.o comm/psb_z_linmap_mod.o \ + comm/psb_comm_mod.o \ + comm/psb_i_comm_mod.o comm/psb_l_comm_mod.o \ + comm/psb_s_comm_mod.o comm/psb_d_comm_mod.o\ + comm/psb_c_comm_mod.o comm/psb_z_comm_mod.o \ + comm/psb_m_comm_a_mod.o comm/psb_e_comm_a_mod.o \ + comm/psb_s_comm_a_mod.o comm/psb_d_comm_a_mod.o\ + comm/psb_c_comm_a_mod.o comm/psb_z_comm_a_mod.o \ + comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o \ + comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \ + comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o \ + comm/psi_i_comm_v_mod.o comm/psi_l_comm_v_mod.o \ + comm/psi_s_comm_v_mod.o comm/psi_d_comm_v_mod.o \ + comm/psi_c_comm_v_mod.o comm/psi_z_comm_v_mod.o \ + psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o \ + psblas/psb_d_psblas_mod.o psblas/psb_z_psblas_mod.o \ + psblas/psb_psblas_mod.o \ + psb_check_mod.o desc/psb_hash_mod.o + -MODULES=$(BASIC_MODS) $(UTIL_MODS) +MODULES=$(BASIC_MODS) $(SERIAL_MODS) $(UTIL_MODS) OBJS = error.o psb_base_mod.o $(EXTRA_COBJS) cutil.o LIBDIR=.. CINCLUDES=-I. @@ -118,8 +120,8 @@ $(LIBDIR)/$(LIBNAME): $(MODULES) $(OBJS) $(MPFOBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(MPFOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) - -psb_error_mod.o: psb_const_mod.o +$(OBJS): $(MODULES) +psb_error_mod.o: psb_const_mod.o psb_realloc_mod.o \ auxil/psb_m_realloc_mod.o \ auxil/psb_e_realloc_mod.o \ @@ -129,7 +131,6 @@ psb_realloc_mod.o \ auxil/psb_z_realloc_mod.o: psb_error_mod.o $(UTIL_MODS): $(BASIC_MODS) -penv/psi_penv_mod.o: penv/psi_comm_buffers_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o penv/psi_collective_mod.o penv/psi_p2p_mod.o: penv/psi_penv_mod.o psb_realloc_mod.o: auxil/psb_m_realloc_mod.o \ @@ -161,10 +162,15 @@ penv/psi_d_collective_mod.o penv/psi_c_collective_mod.o penv/psi_z_collective_m penv/psi_d_p2p_mod.o penv/psi_c_p2p_mod.o penv/psi_z_p2p_mod.o -auxil/psb_string_mod.o desc/psb_desc_const_mod.o psi_comm_buffers_mod.o: psb_const_mod.o -desc/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o desc/psb_desc_const_mod.o +auxil/psb_string_mod.o auxil/psb_m_realloc_mod.o auxil/psb_e_realloc_mod.o auxil/psb_s_realloc_mod.o \ +auxil/psb_d_realloc_mod.o auxil/psb_c_realloc_mod.o auxil/psb_z_realloc_mod.o \ +desc/psb_desc_const_mod.o psi_penv_mod.o: psb_const_mod.o + + +desc/psb_indx_map_mod.o desc/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o desc/psb_desc_const_mod.o auxil/psb_i_sort_mod.o auxil/psb_s_sort_mod.o auxil/psb_d_sort_mod.o auxil/psb_c_sort_mod.o auxil/psb_z_sort_mod.o \ auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o auxil/psb_sort_mod.o: $(BASIC_MODS) + auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ @@ -185,6 +191,28 @@ auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_z_hsort_x_mod.o \ auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o +auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ +auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ +auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ +auxil/psb_e_msort_mod.o auxil/psb_e_qsort_mod.o \ +auxil/psb_s_hsort_mod.o auxil/psb_s_isort_mod.o \ +auxil/psb_s_msort_mod.o auxil/psb_s_qsort_mod.o \ +auxil/psb_d_hsort_mod.o auxil/psb_d_isort_mod.o \ +auxil/psb_d_msort_mod.o auxil/psb_d_qsort_mod.o \ +auxil/psb_c_hsort_mod.o auxil/psb_c_isort_mod.o \ +auxil/psb_c_msort_mod.o auxil/psb_c_qsort_mod.o \ +auxil/psb_z_hsort_mod.o auxil/psb_z_isort_mod.o \ +auxil/psb_z_msort_mod.o auxil/psb_z_qsort_mod.o \ +auxil/psb_i_hsort_x_mod.o \ +auxil/psb_l_hsort_x_mod.o \ +auxil/psb_s_hsort_x_mod.o \ +auxil/psb_d_hsort_x_mod.o \ +auxil/psb_c_hsort_x_mod.o \ +auxil/psb_z_hsort_x_mod.o \ +auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ +auxil/psb_s_ip_reord_mod.o auxil/psb_d_ip_reord_mod.o \ +auxil/psb_c_ip_reord_mod.o auxil/psb_z_ip_reord_mod.o : psb_realloc_mod.o psb_const_mod.o + auxil/psb_i_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o auxil/psb_l_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o @@ -273,7 +301,7 @@ desc/psb_glist_map_mod.o: desc/psb_list_map_mod.o desc/psb_hash_map_mod.o: desc/psb_hash_mod.o auxil/psb_sort_mod.o desc/psb_gen_block_map_mod.o: desc/psb_hash_mod.o desc/psb_hash_mod.o: psb_cbind_const_mod.o - +psb_cbind_const_mod.o: psb_const_mod.o psb_check_mod.o: desc/psb_desc_mod.o comm/psb_linmap_mod.o: comm/psb_s_linmap_mod.o comm/psb_d_linmap_mod.o comm/psb_c_linmap_mod.o comm/psb_z_linmap_mod.o @@ -347,14 +375,14 @@ psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o psblas/psb_d_psblas_mod.o ps psb_base_mod.o: $(MODULES) -penv/psi_penv_mod.o: penv/psi_penv_mod.F90 $(BASIC_MODS) serial/psb_vect_mod.o serial/psb_mat_mod.o +penv/psi_penv_mod.o: penv/psi_penv_mod.F90 psb_const_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ psb_penv_mod.o: psb_penv_mod.F90 $(COMMINT) $(BASIC_MODS) $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ -penv/psi_comm_buffers_mod.o: penv/psi_comm_buffers_mod.F90 $(BASIC_MODS) - $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ +#penv/psi_comm_buffers_mod.o: penv/psi_comm_buffers_mod.F90 $(BASIC_MODS) +# $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ penv/psi_p2p_mod.o: penv/psi_p2p_mod.F90 $(BASIC_MODS) $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ diff --git a/base/modules/comm/psb_base_linmap_mod.f90 b/base/modules/comm/psb_base_linmap_mod.f90 index 38ed3660..a0b62d54 100644 --- a/base/modules/comm/psb_base_linmap_mod.f90 +++ b/base/modules/comm/psb_base_linmap_mod.f90 @@ -47,13 +47,14 @@ module psb_base_linmap_mod type(psb_desc_type), pointer :: p_desc_U=>null(), p_desc_V=>null() type(psb_desc_type) :: desc_U, desc_V contains - procedure, pass(map) :: sizeof => base_map_sizeof - procedure, pass(map) :: is_ok => base_is_ok - procedure, pass(map) :: is_asb => base_is_asb - procedure, pass(map) :: get_kind => base_get_kind - procedure, pass(map) :: set_kind => base_set_kind - procedure, pass(map) :: free => base_free - procedure, pass(map) :: clone => base_clone + procedure, pass(map) :: sizeof => base_map_sizeof + procedure, pass(map) :: is_ok => base_is_ok + procedure, pass(map) :: is_asb => base_is_asb + procedure, pass(map) :: is_v_repl => base_is_v_repl + procedure, pass(map) :: get_kind => base_get_kind + procedure, pass(map) :: set_kind => base_set_kind + procedure, pass(map) :: free => base_free + procedure, pass(map) :: clone => base_clone end type psb_base_linmap_type @@ -61,7 +62,7 @@ module psb_base_linmap_mod module procedure psb_base_linmap_transfer end interface - private :: base_map_sizeof, base_is_ok, base_is_asb,& + private :: base_map_sizeof, base_is_ok, base_is_asb, base_is_v_repl, & & base_get_kind, base_set_kind, base_free, base_clone contains @@ -84,7 +85,6 @@ contains end subroutine base_set_kind - function base_is_ok(map) result(res) use psb_desc_mod implicit none @@ -103,6 +103,23 @@ contains end function base_is_ok + function base_is_v_repl(map) result(res) + use psb_desc_mod + implicit none + class(psb_base_linmap_type), intent(in) :: map + logical :: res + res = .false. + + select case(map%get_kind()) + case (psb_map_aggr_) + if (.not.associated(map%p_desc_V)) return + res = map%p_desc_V%is_repl() + case(psb_map_gen_linear_) + res = map%desc_V%is_repl() + end select + + end function base_is_v_repl + function base_is_asb(map) result(res) use psb_desc_mod implicit none diff --git a/base/modules/comm/psb_c_comm_a_mod.f90 b/base/modules/comm/psb_c_comm_a_mod.f90 index 5d0b236e..0fbcf01e 100644 --- a/base/modules/comm/psb_c_comm_a_mod.f90 +++ b/base/modules/comm/psb_c_comm_a_mod.f90 @@ -38,7 +38,7 @@ module psb_c_comm_a_mod implicit none complex(psb_spk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info complex(psb_spk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_covrlm @@ -47,7 +47,7 @@ module psb_c_comm_a_mod implicit none complex(psb_spk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info complex(psb_spk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_covrlv @@ -68,8 +68,8 @@ module psb_c_comm_a_mod import implicit none complex(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info complex(psb_spk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran diff --git a/base/modules/comm/psb_d_comm_a_mod.f90 b/base/modules/comm/psb_d_comm_a_mod.f90 index 8053f2d5..5fb410f2 100644 --- a/base/modules/comm/psb_d_comm_a_mod.f90 +++ b/base/modules/comm/psb_d_comm_a_mod.f90 @@ -38,7 +38,7 @@ module psb_d_comm_a_mod implicit none real(psb_dpk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info real(psb_dpk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_dovrlm @@ -47,7 +47,7 @@ module psb_d_comm_a_mod implicit none real(psb_dpk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info real(psb_dpk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_dovrlv @@ -68,8 +68,8 @@ module psb_d_comm_a_mod import implicit none real(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info real(psb_dpk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran diff --git a/base/modules/comm/psb_e_comm_a_mod.f90 b/base/modules/comm/psb_e_comm_a_mod.f90 index 46057d94..0e57a459 100644 --- a/base/modules/comm/psb_e_comm_a_mod.f90 +++ b/base/modules/comm/psb_e_comm_a_mod.f90 @@ -39,7 +39,7 @@ module psb_e_comm_a_mod implicit none integer(psb_epk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_epk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_eovrlm @@ -48,7 +48,7 @@ module psb_e_comm_a_mod implicit none integer(psb_epk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_epk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_eovrlv @@ -69,8 +69,8 @@ module psb_e_comm_a_mod import implicit none integer(psb_epk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info integer(psb_epk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran diff --git a/base/modules/comm/psb_i2_comm_a_mod.f90 b/base/modules/comm/psb_i2_comm_a_mod.f90 index 09398722..72cdf228 100644 --- a/base/modules/comm/psb_i2_comm_a_mod.f90 +++ b/base/modules/comm/psb_i2_comm_a_mod.f90 @@ -39,7 +39,7 @@ module psb_i2_comm_a_mod implicit none integer(psb_i2pk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_i2ovrlm @@ -48,7 +48,7 @@ module psb_i2_comm_a_mod implicit none integer(psb_i2pk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_i2ovrlv @@ -69,8 +69,8 @@ module psb_i2_comm_a_mod import implicit none integer(psb_i2pk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran diff --git a/base/modules/comm/psb_m_comm_a_mod.f90 b/base/modules/comm/psb_m_comm_a_mod.f90 index dbec118a..105f14d7 100644 --- a/base/modules/comm/psb_m_comm_a_mod.f90 +++ b/base/modules/comm/psb_m_comm_a_mod.f90 @@ -39,7 +39,7 @@ module psb_m_comm_a_mod implicit none integer(psb_mpk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_movrlm @@ -48,7 +48,7 @@ module psb_m_comm_a_mod implicit none integer(psb_mpk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_movrlv @@ -69,8 +69,8 @@ module psb_m_comm_a_mod import implicit none integer(psb_mpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran diff --git a/base/modules/comm/psb_s_comm_a_mod.f90 b/base/modules/comm/psb_s_comm_a_mod.f90 index 9e7a768a..5ceaad8b 100644 --- a/base/modules/comm/psb_s_comm_a_mod.f90 +++ b/base/modules/comm/psb_s_comm_a_mod.f90 @@ -38,7 +38,7 @@ module psb_s_comm_a_mod implicit none real(psb_spk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info real(psb_spk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_sovrlm @@ -47,7 +47,7 @@ module psb_s_comm_a_mod implicit none real(psb_spk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info real(psb_spk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_sovrlv @@ -68,8 +68,8 @@ module psb_s_comm_a_mod import implicit none real(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info real(psb_spk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran diff --git a/base/modules/comm/psb_z_comm_a_mod.f90 b/base/modules/comm/psb_z_comm_a_mod.f90 index 0c276945..708efead 100644 --- a/base/modules/comm/psb_z_comm_a_mod.f90 +++ b/base/modules/comm/psb_z_comm_a_mod.f90 @@ -38,7 +38,7 @@ module psb_z_comm_a_mod implicit none complex(psb_dpk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_zovrlm @@ -47,7 +47,7 @@ module psb_z_comm_a_mod implicit none complex(psb_dpk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_), intent(inout), optional, target :: work(:) integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_zovrlv @@ -68,8 +68,8 @@ module psb_z_comm_a_mod import implicit none complex(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran diff --git a/base/modules/comm/psi_c_comm_a_mod.f90 b/base/modules/comm/psi_c_comm_a_mod.f90 index 030d7465..1277efdf 100644 --- a/base/modules/comm/psi_c_comm_a_mod.f90 +++ b/base/modules/comm/psi_c_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_c_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type interface psi_swapdata subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) @@ -51,20 +52,24 @@ module psi_c_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswapdatav - subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_cswapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:,:), beta complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_cswapidxm - subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_cswapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_Mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -91,20 +96,24 @@ module psi_c_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptranv - subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_ctranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:,:), beta complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ctranidxm - subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_ctranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -115,16 +124,16 @@ module psi_c_comm_a_mod subroutine psi_covrl_updr1(x,desc_a,update,info) import complex(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_updr1 subroutine psi_covrl_updr2(x,desc_a,update,info) import complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_updr2 end interface psi_ovrl_upd @@ -134,14 +143,14 @@ module psi_c_comm_a_mod complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_saver1 subroutine psi_covrl_saver2(x,xs,desc_a,info) import complex(psb_spk_), intent(inout) :: x(:,:) complex(psb_spk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_saver2 end interface psi_ovrl_save @@ -151,14 +160,14 @@ module psi_c_comm_a_mod complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_restrr1 subroutine psi_covrl_restrr2(x,xs,desc_a,info) import complex(psb_spk_), intent(inout) :: x(:,:) complex(psb_spk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_restrr2 end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_c_comm_v_mod.f90 b/base/modules/comm/psi_c_comm_v_mod.f90 index 78fee8ae..7d10a028 100644 --- a/base/modules/comm/psi_c_comm_v_mod.f90 +++ b/base/modules/comm/psi_c_comm_v_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_c_comm_v_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_spk_, psb_i_base_vect_type use psb_c_base_vect_mod, only : psb_c_base_vect_type use psb_c_base_multivect_mod, only : psb_c_base_multivect_type @@ -43,7 +44,7 @@ module psi_c_comm_v_mod complex(psb_spk_) :: beta complex(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_vect subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) import @@ -53,12 +54,14 @@ module psi_c_comm_v_mod complex(psb_spk_) :: beta complex(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_multivect - subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_cswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y complex(psb_spk_) :: beta @@ -66,12 +69,14 @@ module psi_c_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_cswap_vidx_vect - subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_cswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_multivect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y complex(psb_spk_) :: beta complex(psb_spk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx @@ -101,22 +106,26 @@ module psi_c_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptran_multivect - subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_ctran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type) :: y complex(psb_spk_) :: beta complex(psb_spk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ctran_vidx_vect - subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_ctran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y complex(psb_spk_) :: beta complex(psb_spk_), target :: work(:) diff --git a/base/modules/comm/psi_d_comm_a_mod.f90 b/base/modules/comm/psi_d_comm_a_mod.f90 index 43b74b1d..e2b0aa87 100644 --- a/base/modules/comm/psi_d_comm_a_mod.f90 +++ b/base/modules/comm/psi_d_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_d_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type interface psi_swapdata subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) @@ -51,20 +52,24 @@ module psi_d_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdatav - subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:,:), beta real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxm - subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_dswapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_Mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -91,20 +96,24 @@ module psi_d_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptranv - subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_dtranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:,:), beta real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dtranidxm - subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_dtranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -115,16 +124,16 @@ module psi_d_comm_a_mod subroutine psi_dovrl_updr1(x,desc_a,update,info) import real(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_updr1 subroutine psi_dovrl_updr2(x,desc_a,update,info) import real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_updr2 end interface psi_ovrl_upd @@ -134,14 +143,14 @@ module psi_d_comm_a_mod real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_saver1 subroutine psi_dovrl_saver2(x,xs,desc_a,info) import real(psb_dpk_), intent(inout) :: x(:,:) real(psb_dpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_saver2 end interface psi_ovrl_save @@ -151,14 +160,14 @@ module psi_d_comm_a_mod real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_restrr1 subroutine psi_dovrl_restrr2(x,xs,desc_a,info) import real(psb_dpk_), intent(inout) :: x(:,:) real(psb_dpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_restrr2 end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_d_comm_v_mod.f90 b/base/modules/comm/psi_d_comm_v_mod.f90 index 41aeab6f..b7a902da 100644 --- a/base/modules/comm/psi_d_comm_v_mod.f90 +++ b/base/modules/comm/psi_d_comm_v_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_d_comm_v_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_dpk_, psb_i_base_vect_type use psb_d_base_vect_mod, only : psb_d_base_vect_type use psb_d_base_multivect_mod, only : psb_d_base_multivect_type @@ -43,7 +44,7 @@ module psi_d_comm_v_mod real(psb_dpk_) :: beta real(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_vect subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) import @@ -53,12 +54,14 @@ module psi_d_comm_v_mod real(psb_dpk_) :: beta real(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_multivect - subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_dswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y real(psb_dpk_) :: beta @@ -66,12 +69,14 @@ module psi_d_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dswap_vidx_vect - subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_multivect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y real(psb_dpk_) :: beta real(psb_dpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx @@ -101,22 +106,26 @@ module psi_d_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_multivect - subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_dtran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type) :: y real(psb_dpk_) :: beta real(psb_dpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dtran_vidx_vect - subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_dtran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y real(psb_dpk_) :: beta real(psb_dpk_), target :: work(:) diff --git a/base/modules/comm/psi_e_comm_a_mod.f90 b/base/modules/comm/psi_e_comm_a_mod.f90 index 98522486..8c0d48ff 100644 --- a/base/modules/comm/psi_e_comm_a_mod.f90 +++ b/base/modules/comm/psi_e_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_e_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_ + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ interface psi_swapdata subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) @@ -51,20 +52,24 @@ module psi_e_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_eswapdatav - subroutine psi_eswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_eswapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:,:), beta integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_eswapidxm - subroutine psi_eswapidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_eswapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_Mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -91,20 +96,24 @@ module psi_e_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_eswaptranv - subroutine psi_etranidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_etranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:,:), beta integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_etranidxm - subroutine psi_etranidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_etranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -115,16 +124,16 @@ module psi_e_comm_a_mod subroutine psi_eovrl_updr1(x,desc_a,update,info) import integer(psb_epk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_updr1 subroutine psi_eovrl_updr2(x,desc_a,update,info) import integer(psb_epk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_updr2 end interface psi_ovrl_upd @@ -134,14 +143,14 @@ module psi_e_comm_a_mod integer(psb_epk_), intent(inout) :: x(:) integer(psb_epk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_saver1 subroutine psi_eovrl_saver2(x,xs,desc_a,info) import integer(psb_epk_), intent(inout) :: x(:,:) integer(psb_epk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_saver2 end interface psi_ovrl_save @@ -151,14 +160,14 @@ module psi_e_comm_a_mod integer(psb_epk_), intent(inout) :: x(:) integer(psb_epk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_restrr1 subroutine psi_eovrl_restrr2(x,xs,desc_a,info) import integer(psb_epk_), intent(inout) :: x(:,:) integer(psb_epk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_restrr2 end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_i2_comm_a_mod.f90 b/base/modules/comm/psi_i2_comm_a_mod.f90 index f67b5654..49f1af71 100644 --- a/base/modules/comm/psi_i2_comm_a_mod.f90 +++ b/base/modules/comm/psi_i2_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_i2_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_ + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ interface psi_swapdata subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) @@ -51,20 +52,24 @@ module psi_i2_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_i2swapdatav - subroutine psi_i2swapidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_i2swapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:,:), beta integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2swapidxm - subroutine psi_i2swapidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_i2swapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_Mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -91,20 +96,24 @@ module psi_i2_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_i2swaptranv - subroutine psi_i2tranidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_i2tranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:,:), beta integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2tranidxm - subroutine psi_i2tranidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_i2tranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -115,16 +124,16 @@ module psi_i2_comm_a_mod subroutine psi_i2ovrl_updr1(x,desc_a,update,info) import integer(psb_i2pk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_updr1 subroutine psi_i2ovrl_updr2(x,desc_a,update,info) import integer(psb_i2pk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_updr2 end interface psi_ovrl_upd @@ -134,14 +143,14 @@ module psi_i2_comm_a_mod integer(psb_i2pk_), intent(inout) :: x(:) integer(psb_i2pk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_saver1 subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) import integer(psb_i2pk_), intent(inout) :: x(:,:) integer(psb_i2pk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_saver2 end interface psi_ovrl_save @@ -151,14 +160,14 @@ module psi_i2_comm_a_mod integer(psb_i2pk_), intent(inout) :: x(:) integer(psb_i2pk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_restrr1 subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) import integer(psb_i2pk_), intent(inout) :: x(:,:) integer(psb_i2pk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_restrr2 end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_i_comm_v_mod.f90 b/base/modules/comm/psi_i_comm_v_mod.f90 index bc4ea2a8..2fe3948c 100644 --- a/base/modules/comm/psi_i_comm_v_mod.f90 +++ b/base/modules/comm/psi_i_comm_v_mod.f90 @@ -30,6 +30,7 @@ ! ! module psi_i_comm_v_mod + use psi_penv_mod, only : psb_ctxt_type use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, & & psb_lpk_, psb_epk_, psb_i2pk_ use psb_i_base_vect_mod, only : psb_i_base_vect_type @@ -44,7 +45,7 @@ module psi_i_comm_v_mod integer(psb_ipk_) :: beta integer(psb_ipk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_iswapdata_vect subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) import @@ -54,12 +55,14 @@ module psi_i_comm_v_mod integer(psb_ipk_) :: beta integer(psb_ipk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_iswapdata_multivect - subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_iswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type) :: y integer(psb_ipk_) :: beta @@ -67,12 +70,14 @@ module psi_i_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_iswap_vidx_vect - subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_iswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y integer(psb_ipk_) :: beta integer(psb_ipk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx @@ -102,22 +107,26 @@ module psi_i_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_iswaptran_multivect - subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_itran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y integer(psb_ipk_) :: beta integer(psb_ipk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_itran_vidx_vect - subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_itran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y integer(psb_ipk_) :: beta integer(psb_ipk_), target :: work(:) diff --git a/base/modules/comm/psi_l_comm_v_mod.f90 b/base/modules/comm/psi_l_comm_v_mod.f90 index 4c80b090..b61a17b7 100644 --- a/base/modules/comm/psi_l_comm_v_mod.f90 +++ b/base/modules/comm/psi_l_comm_v_mod.f90 @@ -30,6 +30,7 @@ ! ! module psi_l_comm_v_mod + use psi_penv_mod, only : psb_ctxt_type use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, & & psb_lpk_, psb_epk_, psb_i2pk_ use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_, psb_i_base_vect_type @@ -45,7 +46,7 @@ module psi_l_comm_v_mod integer(psb_lpk_) :: beta integer(psb_lpk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_lswapdata_vect subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) import @@ -55,12 +56,14 @@ module psi_l_comm_v_mod integer(psb_lpk_) :: beta integer(psb_lpk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_lswapdata_multivect - subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_lswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type) :: y integer(psb_lpk_) :: beta @@ -68,12 +71,14 @@ module psi_l_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_lswap_vidx_vect - subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_lswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_multivect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y integer(psb_lpk_) :: beta integer(psb_lpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx @@ -103,22 +108,26 @@ module psi_l_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_lswaptran_multivect - subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_ltran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_vect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y integer(psb_lpk_) :: beta integer(psb_lpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ltran_vidx_vect - subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_ltran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_l_base_multivect_type) :: y integer(psb_lpk_) :: beta integer(psb_lpk_), target :: work(:) diff --git a/base/modules/comm/psi_m_comm_a_mod.f90 b/base/modules/comm/psi_m_comm_a_mod.f90 index 4d0608c3..ca49efa5 100644 --- a/base/modules/comm/psi_m_comm_a_mod.f90 +++ b/base/modules/comm/psi_m_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_m_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_ + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ interface psi_swapdata subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) @@ -51,20 +52,24 @@ module psi_m_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_mswapdatav - subroutine psi_mswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_mswapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:,:), beta integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mswapidxm - subroutine psi_mswapidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_mswapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_Mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -91,20 +96,24 @@ module psi_m_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_mswaptranv - subroutine psi_mtranidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_mtranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:,:), beta integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mtranidxm - subroutine psi_mtranidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_mtranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -115,16 +124,16 @@ module psi_m_comm_a_mod subroutine psi_movrl_updr1(x,desc_a,update,info) import integer(psb_mpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_updr1 subroutine psi_movrl_updr2(x,desc_a,update,info) import integer(psb_mpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_updr2 end interface psi_ovrl_upd @@ -134,14 +143,14 @@ module psi_m_comm_a_mod integer(psb_mpk_), intent(inout) :: x(:) integer(psb_mpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_saver1 subroutine psi_movrl_saver2(x,xs,desc_a,info) import integer(psb_mpk_), intent(inout) :: x(:,:) integer(psb_mpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_saver2 end interface psi_ovrl_save @@ -151,14 +160,14 @@ module psi_m_comm_a_mod integer(psb_mpk_), intent(inout) :: x(:) integer(psb_mpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_restrr1 subroutine psi_movrl_restrr2(x,xs,desc_a,info) import integer(psb_mpk_), intent(inout) :: x(:,:) integer(psb_mpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_restrr2 end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_s_comm_a_mod.f90 b/base/modules/comm/psi_s_comm_a_mod.f90 index e3fdabb2..f2d3ae79 100644 --- a/base/modules/comm/psi_s_comm_a_mod.f90 +++ b/base/modules/comm/psi_s_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_s_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type interface psi_swapdata subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) @@ -51,20 +52,24 @@ module psi_s_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswapdatav - subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_sswapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:,:), beta real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_sswapidxm - subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_sswapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_Mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -91,20 +96,24 @@ module psi_s_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptranv - subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_stranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:,:), beta real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_stranidxm - subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_stranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -115,16 +124,16 @@ module psi_s_comm_a_mod subroutine psi_sovrl_updr1(x,desc_a,update,info) import real(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_updr1 subroutine psi_sovrl_updr2(x,desc_a,update,info) import real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_updr2 end interface psi_ovrl_upd @@ -134,14 +143,14 @@ module psi_s_comm_a_mod real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_saver1 subroutine psi_sovrl_saver2(x,xs,desc_a,info) import real(psb_spk_), intent(inout) :: x(:,:) real(psb_spk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_saver2 end interface psi_ovrl_save @@ -151,14 +160,14 @@ module psi_s_comm_a_mod real(psb_spk_), intent(inout) :: x(:) real(psb_spk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_restrr1 subroutine psi_sovrl_restrr2(x,xs,desc_a,info) import real(psb_spk_), intent(inout) :: x(:,:) real(psb_spk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_restrr2 end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_s_comm_v_mod.f90 b/base/modules/comm/psi_s_comm_v_mod.f90 index 9e7f525d..1cf4d53e 100644 --- a/base/modules/comm/psi_s_comm_v_mod.f90 +++ b/base/modules/comm/psi_s_comm_v_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_s_comm_v_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_spk_, psb_i_base_vect_type use psb_s_base_vect_mod, only : psb_s_base_vect_type use psb_s_base_multivect_mod, only : psb_s_base_multivect_type @@ -43,7 +44,7 @@ module psi_s_comm_v_mod real(psb_spk_) :: beta real(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_vect subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) import @@ -53,12 +54,14 @@ module psi_s_comm_v_mod real(psb_spk_) :: beta real(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_multivect - subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_sswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y real(psb_spk_) :: beta @@ -66,12 +69,14 @@ module psi_s_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_sswap_vidx_vect - subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_sswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_multivect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y real(psb_spk_) :: beta real(psb_spk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx @@ -101,22 +106,26 @@ module psi_s_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptran_multivect - subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_stran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type) :: y real(psb_spk_) :: beta real(psb_spk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_stran_vidx_vect - subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_stran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y real(psb_spk_) :: beta real(psb_spk_), target :: work(:) diff --git a/base/modules/comm/psi_z_comm_a_mod.f90 b/base/modules/comm/psi_z_comm_a_mod.f90 index c3dcd876..16872677 100644 --- a/base/modules/comm/psi_z_comm_a_mod.f90 +++ b/base/modules/comm/psi_z_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_z_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type interface psi_swapdata subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) @@ -51,20 +52,24 @@ module psi_z_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswapdatav - subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_zswapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_zswapidxm - subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_zswapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_Mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -91,20 +96,24 @@ module psi_z_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptranv - subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,& + subroutine psi_ztranidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ztranidxm - subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,& + subroutine psi_ztranidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv @@ -115,16 +124,16 @@ module psi_z_comm_a_mod subroutine psi_zovrl_updr1(x,desc_a,update,info) import complex(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_updr1 subroutine psi_zovrl_updr2(x,desc_a,update,info) import complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_updr2 end interface psi_ovrl_upd @@ -134,14 +143,14 @@ module psi_z_comm_a_mod complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_saver1 subroutine psi_zovrl_saver2(x,xs,desc_a,info) import complex(psb_dpk_), intent(inout) :: x(:,:) complex(psb_dpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_saver2 end interface psi_ovrl_save @@ -151,14 +160,14 @@ module psi_z_comm_a_mod complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_restrr1 subroutine psi_zovrl_restrr2(x,xs,desc_a,info) import complex(psb_dpk_), intent(inout) :: x(:,:) complex(psb_dpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_restrr2 end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_z_comm_v_mod.f90 b/base/modules/comm/psi_z_comm_v_mod.f90 index 9e9816e6..de8e1117 100644 --- a/base/modules/comm/psi_z_comm_v_mod.f90 +++ b/base/modules/comm/psi_z_comm_v_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_z_comm_v_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_dpk_, psb_i_base_vect_type use psb_z_base_vect_mod, only : psb_z_base_vect_type use psb_z_base_multivect_mod, only : psb_z_base_multivect_type @@ -43,7 +44,7 @@ module psi_z_comm_v_mod complex(psb_dpk_) :: beta complex(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_vect subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) import @@ -53,12 +54,14 @@ module psi_z_comm_v_mod complex(psb_dpk_) :: beta complex(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_multivect - subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_zswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y complex(psb_dpk_) :: beta @@ -66,12 +69,14 @@ module psi_z_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_zswap_vidx_vect - subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_zswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_multivect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y complex(psb_dpk_) :: beta complex(psb_dpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx @@ -101,22 +106,26 @@ module psi_z_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptran_multivect - subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_ztran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type) :: y complex(psb_dpk_) :: beta complex(psb_dpk_), target :: work(:) class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ztran_vidx_vect - subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + subroutine psi_ztran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y complex(psb_dpk_) :: beta complex(psb_dpk_), target :: work(:) diff --git a/base/modules/desc/psb_desc_mod.F90 b/base/modules/desc/psb_desc_mod.F90 index 6378c699..c1c98d51 100644 --- a/base/modules/desc/psb_desc_mod.F90 +++ b/base/modules/desc/psb_desc_mod.F90 @@ -1,4 +1,4 @@ - +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 ! Salvatore Filippone @@ -395,17 +395,17 @@ contains val = (m > psb_cd_get_large_threshold()) end function psb_cd_is_large_size - function psb_cd_choose_large_state(ictxt,m) result(val) + function psb_cd_choose_large_state(ctxt,m) result(val) use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_lpk_), intent(in) :: m + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_lpk_), intent(in) :: m logical :: val !locals integer(psb_ipk_) :: np,me - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ! Since the hashed lists take up (somewhat) more than 2*N_COL integers, ! it makes no sense to use them if you don't have at least @@ -435,7 +435,7 @@ contains function psb_is_ok_desc(desc) result(val) implicit none class(psb_desc_type), intent(in) :: desc - logical :: val + logical :: val val = .false. if (allocated(desc%indxmap)) & @@ -446,7 +446,7 @@ contains function psb_is_valid_desc(desc) result(val) implicit none class(psb_desc_type), intent(in) :: desc - logical :: val + logical :: val val = .false. if (allocated(desc%indxmap)) & @@ -468,7 +468,7 @@ contains function psb_is_upd_desc(desc) result(val) implicit none class(psb_desc_type), intent(in) :: desc - logical :: val + logical :: val val = .false. if (allocated(desc%indxmap)) & @@ -479,7 +479,7 @@ contains function psb_is_repl_desc(desc) result(val) implicit none class(psb_desc_type), intent(in) :: desc - logical :: val + logical :: val val = .false. if (allocated(desc%indxmap)) & @@ -490,7 +490,7 @@ contains function psb_is_ovl_desc(desc) result(val) implicit none class(psb_desc_type), intent(in) :: desc - logical :: val + logical :: val val = .false. if (allocated(desc%indxmap)) & @@ -502,7 +502,7 @@ contains function psb_is_asb_desc(desc) result(val) implicit none class(psb_desc_type), intent(in) :: desc - logical :: val + logical :: val val = .false. if (allocated(desc%indxmap)) & @@ -608,14 +608,15 @@ contains function psb_cd_get_context(desc) result(val) use psb_error_mod implicit none - integer(psb_ipk_) :: val + type(psb_ctxt_type) :: val class(psb_desc_type), intent(in) :: desc if (allocated(desc%indxmap)) then val = desc%indxmap%get_ctxt() else - val = -1 - call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_context') - call psb_error() + ! At this point, val should a non-ALLOCATED + ! ctxt component, which suits us just fine. + !call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_context') + !call psb_error() end if end function psb_cd_get_context @@ -745,24 +746,25 @@ contains use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: data - integer(psb_ipk_), pointer :: ipnt(:) - class(psb_desc_type), target :: desc - integer(psb_ipk_), intent(out) :: totxch,idxr,idxs,info + integer(psb_ipk_), intent(in) :: data + integer(psb_ipk_), pointer :: ipnt(:) + class(psb_desc_type), target :: desc + integer(psb_ipk_), intent(out) :: totxch,idxr,idxs,info !locals - integer(psb_ipk_) :: np,me,ictxt,err_act, debug_level,debug_unit - logical, parameter :: debug=.false.,debugprt=.false. - character(len=20), parameter :: name='psb_cd_get_list' + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, debug_level, debug_unit + logical, parameter :: debug=.false., debugprt=.false. + character(len=20), parameter :: name='psb_cd_get_list' info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc) + ctxt = psb_cd_get_context(desc) - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) select case(data) case(psb_comm_halo_) @@ -809,24 +811,25 @@ contains use psb_error_mod use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: data - class(psb_i_base_vect_type), pointer :: ipnt - class(psb_desc_type), target :: desc - integer(psb_ipk_), intent(out) :: totxch,idxr,idxs,info + integer(psb_ipk_), intent(in) :: data + class(psb_i_base_vect_type), pointer :: ipnt + class(psb_desc_type), target :: desc + integer(psb_ipk_), intent(out) :: totxch,idxr,idxs,info !locals - integer(psb_ipk_) :: np,me,ictxt,err_act, debug_level,debug_unit - logical, parameter :: debug=.false.,debugprt=.false. - character(len=20), parameter :: name='psb_cd_v_get_list' + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, debug_level, debug_unit + logical, parameter :: debug=.false., debugprt=.false. + character(len=20), parameter :: name='psb_cd_v_get_list' info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc) + ctxt = psb_cd_get_context(desc) - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) select case(data) case(psb_comm_halo_) @@ -895,7 +898,8 @@ contains class(psb_desc_type), intent(inout) :: desc integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act character(len=20) :: name info=psb_success_ @@ -930,7 +934,6 @@ contains !...locals.... integer(psb_ipk_) :: info - if (allocated(desc%halo_index)) & & deallocate(desc%halo_index,stat=info) @@ -990,13 +993,14 @@ contains implicit none !....parameters... - type(psb_desc_type), intent(inout) :: desc - type(psb_desc_type), intent(inout) :: desc_out - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(inout) :: desc + type(psb_desc_type), intent(inout) :: desc_out + integer(psb_ipk_), intent(out) :: info !locals - integer(psb_ipk_) :: np,me,ictxt, err_act - integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name if (psb_get_errstatus() /= 0) return @@ -1010,8 +1014,8 @@ contains ! when desc is empty. ! if (desc%is_valid()) then - ictxt = psb_cd_get_context(desc) - call psb_info(ictxt,me,np) + ctxt = desc%get_ctxt() + call psb_info(ctxt,me,np) if (info == psb_success_) & & call psb_move_alloc( desc%halo_index , desc_out%halo_index , info) @@ -1083,8 +1087,9 @@ contains class(psb_desc_type), intent(inout) :: desc_out integer(psb_ipk_), intent(out) :: info !locals - integer(psb_ipk_) :: np,me,ictxt, err_act - integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name debug_unit = psb_get_debug_unit() @@ -1097,10 +1102,10 @@ contains call desc_out%free(info) if ((info == psb_success_).and.desc%is_valid()) then - ictxt = desc%get_context() + ctxt = desc%get_ctxt() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': Entered' if (np == -1) then @@ -1150,7 +1155,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -1162,13 +1167,14 @@ contains use psb_penv_mod use psb_realloc_mod Implicit None - integer(psb_ipk_), allocatable, intent(out) :: tmp(:) - integer(psb_ipk_), intent(in) :: data - Type(psb_desc_type), Intent(in), target :: desc - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), allocatable, intent(out) :: tmp(:) + integer(psb_ipk_), intent(in) :: data + Type(psb_desc_type), Intent(in), target :: desc + integer(psb_ipk_), intent(out) :: info ! .. Local Scalars .. - integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: incnt, outcnt, j, np, me, l_tmp,& & idx, proc, n_elem_send, n_elem_recv integer(psb_ipk_), pointer :: idxlist(:) integer(psb_ipk_) :: debug_level, debug_unit, err_act @@ -1180,8 +1186,8 @@ contains debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc) - call psb_info(ictxt, me, np) + ctxt = desc%get_context() + call psb_info(ctxt, me, np) select case(data) case(psb_comm_halo_) @@ -1236,7 +1242,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -1248,18 +1254,19 @@ contains use psb_penv_mod use psb_realloc_mod Implicit None - integer(psb_lpk_), allocatable, intent(out) :: tmp(:) - integer(psb_ipk_), intent(in) :: data - Type(psb_desc_type), Intent(in), target :: desc - integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable, intent(out) :: tmp(:) + integer(psb_ipk_), intent(in) :: data + type(psb_desc_type), Intent(in), target :: desc + integer(psb_ipk_), intent(out) :: info ! .. Local Scalars .. - integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: incnt, outcnt, j, np, me, l_tmp,& & idx, proc, n_elem_send, n_elem_recv integer(psb_ipk_), pointer :: idxlist(:) integer(psb_lpk_) :: gidx integer(psb_ipk_) :: debug_level, debug_unit, err_act - character(len=20) :: name + character(len=20) :: name name = 'psb_cd_get_recv_idx' info = psb_success_ @@ -1267,8 +1274,8 @@ contains debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(desc) - call psb_info(ictxt, me, np) + ctxt = desc%get_context() + call psb_info(ctxt, me, np) select case(data) case(psb_comm_halo_) @@ -1330,7 +1337,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -1338,7 +1345,7 @@ contains subroutine psb_cd_cnv(desc, mold) class(psb_desc_type), intent(inout), target :: desc - class(psb_i_base_vect_type), intent(in) :: mold + class(psb_i_base_vect_type), intent(in) :: mold call desc%v_halo_index%cnv(mold) call desc%v_ext_index%cnv(mold) @@ -1389,8 +1396,8 @@ contains integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask - logical, intent(in), optional :: owned + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned integer(psb_ipk_) :: err_act character(len=20) :: name='cd_l2g' @@ -1425,8 +1432,8 @@ contains class(psb_desc_type), intent(in) :: desc integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned integer(psb_ipk_) :: err_act character(len=20) :: name='cd_l2g' logical, parameter :: debug=.false. @@ -1460,8 +1467,8 @@ contains integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_lpk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned integer(psb_ipk_) :: err_act character(len=20) :: name='cd_l2g' logical, parameter :: debug=.false. @@ -1495,8 +1502,8 @@ contains class(psb_desc_type), intent(in) :: desc integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask - logical, intent(in), optional :: owned + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned integer(psb_ipk_) :: err_act character(len=20) :: name='cd_g2l' logical, parameter :: debug=.false. @@ -1530,8 +1537,8 @@ contains integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask - logical, intent(in), optional :: owned + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned integer(psb_ipk_) :: err_act character(len=20) :: name='cd_g2l' @@ -1566,8 +1573,8 @@ contains class(psb_desc_type), intent(in) :: desc integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned integer(psb_ipk_) :: err_act character(len=20) :: name='cd_g2l' logical, parameter :: debug=.false. @@ -1601,9 +1608,9 @@ contains integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned - + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_ipk_) :: err_act character(len=20) :: name='cd_g2l' logical, parameter :: debug=.false. @@ -1637,9 +1644,9 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_lpk_), intent(inout) :: idx - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_) :: err_act character(len=20) :: name='cd_g2l_ins' @@ -1671,10 +1678,10 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_lpk_), intent(in) :: idxin - integer(psb_ipk_), intent(out) :: idxout - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask + integer(psb_lpk_), intent(in) :: idxin + integer(psb_ipk_), intent(out) :: idxout + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_) :: err_act @@ -1709,9 +1716,9 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_lpk_), intent(inout) :: idx(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_) :: err_act @@ -1745,10 +1752,10 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_lpk_), intent(in) :: idxin(:) - integer(psb_ipk_), intent(out) :: idxout(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: mask(:) + integer(psb_lpk_), intent(in) :: idxin(:) + integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_) :: err_act @@ -1786,7 +1793,7 @@ contains integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_desc_type), intent(inout) :: desc integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='cd_fnd_owner' logical, parameter :: debug=.false. diff --git a/base/modules/desc/psb_gen_block_map_mod.F90 b/base/modules/desc/psb_gen_block_map_mod.F90 index 6fc8123f..b4f798d9 100644 --- a/base/modules/desc/psb_gen_block_map_mod.F90 +++ b/base/modules/desc/psb_gen_block_map_mod.F90 @@ -535,12 +535,12 @@ contains !!$ logical, intent(in), optional :: owned !!$ integer(psb_ipk_) :: i, nv, is, ip, lip !!$ integer(psb_lpk_) :: tidx -!!$ integer(psb_mpk_) :: ictxt, iam, np +!!$ integer(psb_mpk_) :: ctxt, iam, np !!$ logical :: owned_ !!$ !!$ info = 0 -!!$ ictxt = idxmap%get_ctxt() -!!$ call psb_info(ictxt,iam,np) +!!$ ctxt = idxmap%get_ctxt() +!!$ call psb_info(ctxt,iam,np) !!$ !!$ if (present(mask)) then !!$ if (size(mask) < size(idx)) then @@ -648,12 +648,12 @@ contains !!$ !!$ integer(psb_ipk_) :: i, nv, is, ip, lip, im !!$ integer(psb_lpk_) :: tidx -!!$ integer(psb_mpk_) :: ictxt, iam, np +!!$ integer(psb_mpk_) :: ctxt, iam, np !!$ logical :: owned_ !!$ !!$ info = 0 -!!$ ictxt = idxmap%get_ctxt() -!!$ call psb_info(ictxt,iam,np) +!!$ ctxt = idxmap%get_ctxt() +!!$ call psb_info(ctxt,iam,np) !!$ is = size(idxin) !!$ im = min(is,size(idxout)) !!$ @@ -805,13 +805,14 @@ contains logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned integer(psb_ipk_) :: i, nv, is - integer(psb_lpk_) :: tidx, ip, lip - integer(psb_ipk_) :: ictxt, iam, np + integer(psb_lpk_) :: tidx, ip, lip + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np logical :: owned_ info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) if (present(mask)) then if (size(mask) < size(idx)) then @@ -922,12 +923,13 @@ contains integer(psb_ipk_) :: i, nv, is, im integer(psb_lpk_) :: tidx, ip, lip - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np logical :: owned_ info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) is = size(idxin) im = min(is,size(idxout)) @@ -1938,11 +1940,12 @@ contains integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_gen_block_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, iam, np, nv, ip, i + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np, nv, ip, i integer(psb_lpk_) :: tidx - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) nv = size(idx) allocate(iprc(nv),stat=info) if (info /= 0) then @@ -1958,13 +1961,13 @@ contains - subroutine block_init(idxmap,ictxt,nl,info) + subroutine block_init(idxmap,ctxt,nl,info) use psb_penv_mod use psb_realloc_mod use psb_error_mod implicit none class(psb_gen_block_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: nl integer(psb_ipk_), intent(out) :: info ! To be implemented @@ -1974,9 +1977,9 @@ contains integer(psb_lpk_), allocatable :: vnl(:) info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt' info = -1 return end if @@ -1988,7 +1991,7 @@ contains vnl(:) = 0 vnl(iam) = nl - call psb_sum(ictxt,vnl) + call psb_sum(ctxt,vnl) ntot = sum(vnl) vnl(1:np) = vnl(0:np-1) vnl(0) = 0 @@ -2003,9 +2006,9 @@ contains idxmap%global_cols = ntot idxmap%local_rows = nl idxmap%local_cols = nl - idxmap%ictxt = ictxt + idxmap%ctxt = ctxt idxmap%state = psb_desc_bld_ - idxmap%mpic = psb_get_mpi_comm(ictxt) + idxmap%mpic = psb_get_mpi_comm(ctxt) idxmap%min_glob_row = vnl(iam)+1 idxmap%max_glob_row = vnl(iam+1) call move_alloc(vnl,idxmap%vnl) @@ -2030,11 +2033,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: nhal, i - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np logical :: debug=.false. info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) nhal = idxmap%local_cols-idxmap%local_rows @@ -2135,7 +2139,7 @@ contains implicit none class(psb_gen_block_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, ictxt + integer(psb_ipk_) :: err_act integer(psb_ipk_) :: k, nr, nc integer(psb_lpk_) :: lk integer(psb_ipk_), allocatable :: lidx(:) diff --git a/base/modules/desc/psb_glist_map_mod.f90 b/base/modules/desc/psb_glist_map_mod.f90 index 69169b17..c8ac8f99 100644 --- a/base/modules/desc/psb_glist_map_mod.f90 +++ b/base/modules/desc/psb_glist_map_mod.f90 @@ -91,12 +91,12 @@ contains - subroutine glist_initvg(idxmap,ictxt,vg,info) + subroutine glist_initvg(idxmap,ctxt,vg,info) use psb_penv_mod use psb_error_mod implicit none class(psb_glist_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: vg(:) integer(psb_ipk_), intent(out) :: info ! To be implemented @@ -106,9 +106,9 @@ contains info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt' info = -1 return end if @@ -124,9 +124,9 @@ contains return end if - idxmap%ictxt = ictxt + idxmap%ctxt = ctxt idxmap%state = psb_desc_bld_ - idxmap%mpic = psb_get_mpi_comm(ictxt) + idxmap%mpic = psb_get_mpi_comm(ctxt) nl = 0 do i=1, n @@ -158,11 +158,12 @@ contains integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_glist_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: ictxt, iam, np - integer(psb_lpk_) :: nv, i, ngp + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np + integer(psb_lpk_) :: nv, i, ngp - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) nv = size(idx) allocate(iprc(nv),stat=info) if (info /= 0) then diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.f90 index ae109d5a..6cb781eb 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.f90 @@ -329,12 +329,13 @@ contains logical, intent(in), optional :: owned integer(psb_ipk_) :: i, lip, nrow, nrm, is integer(psb_lpk_) :: ncol, ip, tlip, mglob - integer(psb_mpk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np logical :: owned_ info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) if (present(mask)) then if (size(mask) < size(idx)) then @@ -541,15 +542,16 @@ contains integer(psb_ipk_) :: i, is, lip, nrow, ncol, & & err_act integer(psb_lpk_) :: mglob, ip, nxt, tlip - integer(psb_ipk_) :: ictxt, me, np - character(len=20) :: name,ch_err + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + character(len=20) :: name,ch_err info = psb_success_ name = 'hash_g2l_ins' call psb_erractionsave(err_act) - ictxt = idxmap%get_ctxt() - call psb_info(ictxt, me, np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt, me, np) is = size(idx) @@ -764,7 +766,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -798,14 +800,14 @@ contains ! ! init from VL, with checks on input. ! - subroutine hash_init_vl(idxmap,ictxt,vl,info) + subroutine hash_init_vl(idxmap,ctxt,vl,info) use psb_penv_mod use psb_error_mod use psb_sort_mod use psb_realloc_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_lpk_), intent(in) :: vl(:) integer(psb_ipk_), intent(out) :: info ! To be implemented @@ -817,9 +819,9 @@ contains character(len=20), parameter :: name='hash_map_init_vl' info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt' info = -1 return end if @@ -828,8 +830,8 @@ contains m = maxval(vl(1:nl)) nrt = nl - call psb_sum(ictxt,nrt) - call psb_max(ictxt,m) + call psb_sum(ctxt,nrt) + call psb_max(ctxt,m) allocate(vlu(nl), ix(nl), stat=info) if (info /= 0) then @@ -869,16 +871,16 @@ contains call psb_msort(ix(1:nlu),vlu(1:nlu),flag=psb_sort_keep_idx_) nlu = nl - call hash_init_vlu(idxmap,ictxt,m,nlu,vlu,info) + call hash_init_vlu(idxmap,ctxt,m,nlu,vlu,info) end subroutine hash_init_vl - subroutine hash_init_vg(idxmap,ictxt,vg,info) + subroutine hash_init_vg(idxmap,ctxt,vg,info) use psb_penv_mod use psb_error_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: vg(:) integer(psb_ipk_), intent(out) :: info ! To be implemented @@ -888,9 +890,9 @@ contains integer(psb_lpk_), allocatable :: vlu(:) info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt:' info = -1 return end if @@ -923,7 +925,7 @@ contains end do - call hash_init_vlu(idxmap,ictxt,n,nl,vlu,info) + call hash_init_vlu(idxmap,ctxt,n,nl,vlu,info) end subroutine hash_init_vg @@ -931,14 +933,14 @@ contains ! ! init from VL, with no checks on input ! - subroutine hash_init_vlu(idxmap,ictxt,ntot,nl,vlu,info) + subroutine hash_init_vlu(idxmap,ctxt,ntot,nl,vlu,info) use psb_penv_mod use psb_error_mod use psb_sort_mod use psb_realloc_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_lpk_), intent(in) :: vlu(:), ntot integer(psb_ipk_), intent(in) :: nl integer(psb_ipk_), intent(out) :: info @@ -948,9 +950,9 @@ contains character(len=20), parameter :: name='hash_map_init_vlu' info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt:' info = -1 return end if @@ -959,9 +961,9 @@ contains idxmap%global_cols = ntot idxmap%local_rows = nl idxmap%local_cols = nl - idxmap%ictxt = ictxt + idxmap%ctxt = ctxt idxmap%state = psb_desc_bld_ - idxmap%mpic = psb_get_mpi_comm(ictxt) + idxmap%mpic = psb_get_mpi_comm(ctxt) lc2 = int(1.5*nl) call psb_realloc(lc2,idxmap%loc_to_glob,info) @@ -996,18 +998,19 @@ contains class(psb_hash_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpk_) :: ictxt, iam, np - integer(psb_ipk_) :: i, j, m, nl - integer(psb_ipk_) :: ih, nh, idx, nbits - integer(psb_lpk_) :: key, hsize, hmask + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np + integer(psb_ipk_) :: i, j, m, nl + integer(psb_ipk_) :: ih, nh, idx, nbits + integer(psb_lpk_) :: key, hsize, hmask character(len=20), parameter :: name='hash_map_init_vlu' info = 0 - ictxt = idxmap%get_ctxt() + ctxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt:' info = -1 return end if @@ -1098,14 +1101,15 @@ contains use psb_sort_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: ictxt, iam, np - integer(psb_ipk_) :: nhal + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np + integer(psb_ipk_) :: nhal info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) nhal = max(0,idxmap%local_cols-idxmap%local_rows) @@ -1534,7 +1538,8 @@ contains integer(psb_ipk_) :: err_act, nr,nc,k, nl integer(psb_lpk_) :: lk integer(psb_lpk_) :: ntot - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_ipk_), allocatable :: lidx(:), tadj(:), th_own(:) integer(psb_lpk_), allocatable :: gidx(:) character(len=20) :: name='hash_reinit' @@ -1542,7 +1547,7 @@ contains info = psb_success_ call psb_get_erraction(err_act) - ictxt = idxmap%get_ctxt() + ctxt = idxmap%get_ctxt() nr = idxmap%get_lr() nc = idxmap%get_lc() ntot = idxmap%get_gr() @@ -1555,7 +1560,7 @@ contains call idxmap%get_halo_owner(th_own,info) call idxmap%free() - call hash_init_vlu(idxmap,ictxt,ntot,nr,gidx(1:nr),info) + call hash_init_vlu(idxmap,ctxt,ntot,nr,gidx(1:nr),info) if (nc>nr) then call idxmap%g2lip_ins(gidx(nr+1:nc),info,lidx=lidx(nr+1:nc)) end if diff --git a/base/modules/desc/psb_indx_map_mod.f90 b/base/modules/desc/psb_indx_map_mod.f90 index dd72280b..0c0d8199 100644 --- a/base/modules/desc/psb_indx_map_mod.f90 +++ b/base/modules/desc/psb_indx_map_mod.f90 @@ -40,7 +40,7 @@ module psb_indx_map_mod use psb_const_mod use psb_desc_const_mod - + use psi_penv_mod, only : psb_ctxt_type ! !> \namespace psb_base_mod \class psb_indx_map !! \brief Object to handle the mapping between global and local indices. @@ -106,19 +106,19 @@ module psb_indx_map_mod !! type :: psb_indx_map !> State of the map - integer(psb_ipk_) :: state = psb_desc_null_ + integer(psb_ipk_) :: state = psb_desc_null_ !> Communication context - integer(psb_ipk_) :: ictxt = -1 + type(psb_ctxt_type) :: ctxt !> MPI communicator - integer(psb_mpk_) :: mpic = -1 + integer(psb_mpk_) :: mpic = -1 !> Number of global rows - integer(psb_lpk_) :: global_rows = -1 + integer(psb_lpk_) :: global_rows = -1 !> Number of global columns - integer(psb_lpk_) :: global_cols = -1 + integer(psb_lpk_) :: global_cols = -1 !> Number of local rows - integer(psb_ipk_) :: local_rows = -1 + integer(psb_ipk_) :: local_rows = -1 !> Number of local columns - integer(psb_ipk_) :: local_cols = -1 + integer(psb_ipk_) :: local_cols = -1 !> A pointer to the user-defined parts subroutine procedure(psb_parts), nopass, pointer :: parts => null() !> The global vector assigning indices to processes, temp copy @@ -224,6 +224,7 @@ module psb_indx_map_mod generic, public :: qry_halo_owner => qry_halo_owner_s, qry_halo_owner_v procedure, pass(idxmap) :: fnd_owner => psi_indx_map_fnd_owner + procedure, pass(idxmap) :: init_null => base_init_null procedure, pass(idxmap) :: init_vl => base_init_vl generic, public :: init => init_vl @@ -242,7 +243,7 @@ module psb_indx_map_mod & base_ll2gs1, base_ll2gs2, base_ll2gv1, base_ll2gv2,& & base_lg2ls1, base_lg2ls2, base_lg2lv1, base_lg2lv2,& & base_lg2ls1_ins, base_lg2ls2_ins, base_lg2lv1_ins,& - & base_lg2lv2_ins, base_init_vl, base_is_null,& + & base_lg2lv2_ins, base_init_vl, base_is_null, base_init_null, & & base_row_extendable, base_clone, base_cpy, base_reinit, & & base_set_halo_owner, base_get_halo_owner, & & base_qry_halo_owner_s, base_qry_halo_owner_v,& @@ -334,19 +335,21 @@ module psb_indx_map_mod integer, parameter :: psi_symm_flag_norv_ = 0 integer, parameter :: psi_symm_flag_inrv_ = 1 interface psi_symm_dep_list - subroutine psi_symm_dep_list_inrv(rvsz,adj,ictxt,info) - import :: psb_indx_map, psb_ipk_, psb_lpk_, psb_mpk_ + subroutine psi_symm_dep_list_inrv(rvsz,adj,ctxt,info) + import :: psb_indx_map, psb_ipk_, psb_lpk_, psb_mpk_, & + & psb_ctxt_type implicit none integer(psb_mpk_), intent(inout) :: rvsz(0:) integer(psb_ipk_), allocatable, intent(inout) :: adj(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info end subroutine psi_symm_dep_list_inrv - subroutine psi_symm_dep_list_norv(adj,ictxt,info) - import :: psb_indx_map, psb_ipk_, psb_lpk_, psb_mpk_ + subroutine psi_symm_dep_list_norv(adj,ctxt,info) + import :: psb_indx_map, psb_ipk_, psb_lpk_, psb_mpk_, & + & psb_ctxt_type implicit none integer(psb_ipk_), allocatable, intent(inout) :: adj(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info end subroutine psi_symm_dep_list_norv end interface psi_symm_dep_list @@ -487,9 +490,9 @@ contains function base_get_ctxt(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_) :: val + type(psb_ctxt_type) :: val - val = idxmap%ictxt + val = idxmap%ctxt end function base_get_ctxt @@ -515,9 +518,9 @@ contains subroutine base_set_ctxt(idxmap,val) implicit none class(psb_indx_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: val + type(psb_ctxt_type), intent(in) :: val - idxmap%ictxt = val + idxmap%ctxt = val end subroutine base_set_ctxt subroutine base_set_gri(idxmap,val) @@ -1318,7 +1321,7 @@ contains ! almost nothing to be done here idxmap%state = -1 - idxmap%ictxt = -1 + if (allocated(idxmap%ctxt%ctxt)) deallocate(idxmap%ctxt%ctxt) idxmap%mpic = -1 idxmap%global_rows = -1 idxmap%global_cols = -1 @@ -1334,7 +1337,7 @@ contains class(psb_indx_map), intent(inout) :: idxmap idxmap%state = psb_desc_null_ - idxmap%ictxt = -1 + if (allocated(idxmap%ctxt%ctxt)) deallocate(idxmap%ctxt%ctxt) idxmap%mpic = -1 idxmap%global_rows = -1 idxmap%global_cols = -1 @@ -1343,12 +1346,23 @@ contains end subroutine base_set_null - subroutine base_init_vl(idxmap,ictxt,vl,info) + subroutine base_init_null(idxmap,ctxt,info) + class(psb_indx_map), intent(inout) :: idxmap + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(out) :: info + + call idxmap%set_null() + idxmap%ctxt = ctxt + info = 0 + return + end subroutine base_init_null + + subroutine base_init_vl(idxmap,ctxt,vl,info) use psb_penv_mod use psb_error_mod implicit none class(psb_indx_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_lpk_), intent(in) :: vl(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -1412,7 +1426,7 @@ contains call psb_get_erraction(err_act) outmap%state = idxmap%state - outmap%ictxt = idxmap%ictxt + outmap%ctxt = idxmap%ctxt outmap%mpic = idxmap%mpic outmap%global_rows = idxmap%global_rows outmap%global_cols = idxmap%global_cols @@ -1473,7 +1487,7 @@ contains integer(psb_ipk_) :: me, np integer(psb_ipk_) :: i, j, nr, nc, nh - call psb_info(idxmap%ictxt,me,np) + call psb_info(idxmap%ctxt,me,np) ! The idea here is to store only the halo part nr = idxmap%local_rows nc = idxmap%local_cols diff --git a/base/modules/desc/psb_list_map_mod.f90 b/base/modules/desc/psb_list_map_mod.f90 index aab2a9d4..5c63aa6c 100644 --- a/base/modules/desc/psb_list_map_mod.f90 +++ b/base/modules/desc/psb_list_map_mod.f90 @@ -1039,12 +1039,12 @@ contains - subroutine list_initvl(idxmap,ictxt,vl,info) + subroutine list_initvl(idxmap,ctxt,vl,info) use psb_penv_mod use psb_error_mod implicit none class(psb_list_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: vl(:) integer(psb_ipk_), intent(out) :: info ! To be implemented @@ -1053,9 +1053,9 @@ contains integer(psb_ipk_) :: iam, np info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt:' info = -1 return end if @@ -1068,17 +1068,17 @@ contains end if lvl(1:nl) = vl(1:nl) - call idxmap%init_vl(ictxt,lvl,info) + call idxmap%init_vl(ctxt,lvl,info) end subroutine list_initvl - subroutine list_initlvl(idxmap,ictxt,vl,info) + subroutine list_initlvl(idxmap,ctxt,vl,info) use psb_penv_mod use psb_error_mod implicit none class(psb_list_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_lpk_), intent(in) :: vl(:) integer(psb_ipk_), intent(out) :: info ! To be implemented @@ -1086,9 +1086,9 @@ contains integer(psb_ipk_) :: iam, np info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt:' info = -1 return end if @@ -1098,8 +1098,8 @@ contains n = maxval(vl(1:nl)) nrt = nl - call psb_sum(ictxt,nrt) - call psb_max(ictxt,n) + call psb_sum(ctxt,nrt) + call psb_max(ctxt,n) if (n /= nrt) then @@ -1117,9 +1117,9 @@ contains return end if - idxmap%ictxt = ictxt + idxmap%ctxt = ctxt idxmap%state = psb_desc_bld_ - idxmap%mpic = psb_get_mpi_comm(ictxt) + idxmap%mpic = psb_get_mpi_comm(ctxt) do i=1, n idxmap%glob_to_loc(i) = -1 end do @@ -1147,11 +1147,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: nhal - integer(psb_mpk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) nhal = idxmap%local_cols call psb_realloc(nhal,idxmap%loc_to_glob,info) diff --git a/base/modules/desc/psb_repl_map_mod.f90 b/base/modules/desc/psb_repl_map_mod.f90 index 7b29833b..e0d352e2 100644 --- a/base/modules/desc/psb_repl_map_mod.f90 +++ b/base/modules/desc/psb_repl_map_mod.f90 @@ -703,11 +703,12 @@ contains integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_repl_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: nv - integer(psb_mpk_) :: ictxt, iam, np + integer(psb_ipk_) :: nv + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) nv = size(idx) allocate(iprc(nv),stat=info) @@ -720,21 +721,21 @@ contains end subroutine repl_fnd_owner - subroutine repl_init(idxmap,ictxt,nl,info) + subroutine repl_init(idxmap,ctxt,nl,info) use psb_penv_mod use psb_error_mod implicit none class(psb_repl_map), intent(inout) :: idxmap integer(psb_lpk_), intent(in) :: nl - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info ! To be implemented integer(psb_ipk_) :: iam, np info = 0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt + write(psb_err_unit,*) 'Invalid ctxt:' info = -1 return end if @@ -744,9 +745,9 @@ contains idxmap%global_cols = nl idxmap%local_rows = nl idxmap%local_cols = nl - idxmap%ictxt = ictxt + idxmap%ctxt = ctxt idxmap%state = psb_desc_bld_ - idxmap%mpic = psb_get_mpi_comm(ictxt) + idxmap%mpic = psb_get_mpi_comm(ctxt) call idxmap%set_state(psb_desc_bld_) end subroutine repl_init @@ -759,11 +760,12 @@ contains class(psb_repl_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: iam, np info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = idxmap%get_ctxt() + call psb_info(ctxt,iam,np) call idxmap%set_state(psb_desc_asb_) diff --git a/base/modules/error.f90 b/base/modules/error.f90 index 89411836..10cb1339 100644 --- a/base/modules/error.f90 +++ b/base/modules/error.f90 @@ -33,13 +33,14 @@ ! Wrapper subroutines to provide error tools to F77 and C code ! -subroutine FCpsb_errcomm(ictxt, err) +subroutine FCpsb_errcomm(ctxt, err) use psb_const_mod use psb_error_mod - integer(psb_ipk_), intent(in) :: ictxt + use psi_penv_mod + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(inout):: err - call psb_errcomm(ictxt, err) + call psb_errcomm(ctxt, err) end subroutine FCpsb_errcomm @@ -48,16 +49,14 @@ subroutine FCpsb_errpush(err_c, r_name, i_err) use psb_error_mod implicit none - integer(psb_ipk_), intent(in) :: err_c - character(len=20), intent(in) :: r_name + integer(psb_ipk_), intent(in) :: err_c + character(len=20), intent(in) :: r_name integer(psb_ipk_) :: i_err(5) call psb_errpush(err_c, r_name, i_err=i_err) end subroutine FCpsb_errpush - - subroutine FCpsb_serror() use psb_const_mod use psb_error_mod @@ -67,23 +66,18 @@ subroutine FCpsb_serror() end subroutine FCpsb_serror - - - - -subroutine FCpsb_perror(ictxt) +subroutine FCpsb_perror(ctxt) use psb_const_mod use psb_error_mod + use psi_penv_mod implicit none - integer(psb_ipk_), intent(in) :: ictxt - - call psb_error(ictxt) + type(psb_ctxt_type), intent(in) :: ctxt + + call psb_error(ctxt) end subroutine FCpsb_perror - - function FCpsb_get_errstatus() use psb_const_mod use psb_error_mod @@ -95,7 +89,6 @@ function FCpsb_get_errstatus() end function FCpsb_get_errstatus - subroutine FCpsb_get_errverbosity(v) use psb_const_mod use psb_error_mod @@ -107,8 +100,6 @@ subroutine FCpsb_get_errverbosity(v) end subroutine FCpsb_get_errverbosity - - subroutine FCpsb_set_errverbosity(v) use psb_const_mod use psb_error_mod @@ -120,8 +111,6 @@ subroutine FCpsb_set_errverbosity(v) end subroutine FCpsb_set_errverbosity - - subroutine FCpsb_erractionsave(err_act) use psb_const_mod use psb_error_mod @@ -133,7 +122,6 @@ subroutine FCpsb_erractionsave(err_act) end subroutine FCpsb_erractionsave - subroutine FCpsb_get_erraction(err_act) use psb_const_mod use psb_error_mod @@ -143,8 +131,6 @@ subroutine FCpsb_get_erraction(err_act) call psb_get_erraction(err_act) end subroutine FCpsb_get_erraction - - subroutine FCpsb_erractionrestore(err_act) use psb_const_mod use psb_error_mod @@ -155,9 +141,3 @@ subroutine FCpsb_erractionrestore(err_act) call psb_erractionrestore(err_act) end subroutine FCpsb_erractionrestore - - - - - - diff --git a/base/modules/penv/psi_c_collective_mod.F90 b/base/modules/penv/psi_c_collective_mod.F90 index a1fa78a3..17113ec0 100644 --- a/base/modules/penv/psi_c_collective_mod.F90 +++ b/base/modules/penv/psi_c_collective_mod.F90 @@ -31,28 +31,22 @@ ! module psi_c_collective_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_sum - module procedure psb_csums, psb_csumv, psb_csumm, & - & psb_csums_ec, psb_csumv_ec, psb_csumm_ec + module procedure psb_csums, psb_csumv, psb_csumm end interface interface psb_amx - module procedure psb_camxs, psb_camxv, psb_camxm, & - & psb_camxs_ec, psb_camxv_ec, psb_camxm_ec + module procedure psb_camxs, psb_camxv, psb_camxm end interface interface psb_amn - module procedure psb_camns, psb_camnv, psb_camnm, & - & psb_camns_ec, psb_camnv_ec, psb_camnm_ec + module procedure psb_camns, psb_camnv, psb_camnm end interface - interface psb_bcast - module procedure psb_cbcasts, psb_cbcastv, psb_cbcastm, & - & psb_cbcasts_ec, psb_cbcastv_ec, psb_cbcastm_ec + module procedure psb_cbcasts, psb_cbcastv, psb_cbcastm end interface psb_bcast interface psb_scan_sum @@ -71,7 +65,6 @@ module psi_c_collective_mod module procedure psb_c_e_simple_triad_a2av, psb_c_m_simple_triad_a2av end interface psb_simple_triad_a2av - contains ! !!!!!!!!!!!!!!!!!!!!!! @@ -86,7 +79,7 @@ contains ! SUM ! - subroutine psb_csums(ictxt,dat,root) + subroutine psb_csums(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -94,34 +87,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_csums - subroutine psb_csumv(ictxt,dat,root) + subroutine psb_csumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -130,42 +123,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_csumv - subroutine psb_csumm(ictxt,dat,root) + subroutine psb_csumm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -174,95 +167,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_csumm - subroutine psb_csums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_csums_ec - - subroutine psb_csumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_csumv_ec - - subroutine psb_csumm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_csumm_ec - - ! ! AMX: Maximum Absolute Value ! - subroutine psb_camxs(ictxt,dat,root) + subroutine psb_camxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -270,34 +215,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_camxs - subroutine psb_camxv(ictxt,dat,root) + subroutine psb_camxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -306,42 +251,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) end if endif #endif end subroutine psb_camxv - subroutine psb_camxm(ictxt,dat,root) + subroutine psb_camxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -350,96 +295,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,icomm,info) end if endif #endif end subroutine psb_camxm - - subroutine psb_camxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_camxs_ec - - subroutine psb_camxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_camxv_ec - - subroutine psb_camxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_camxm_ec - - ! ! AMN: Minimum Absolute Value ! - subroutine psb_camns(ictxt,dat,root) + subroutine psb_camns(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -447,34 +343,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_camns - subroutine psb_camnv(ictxt,dat,root) + subroutine psb_camnv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -483,42 +379,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) end if endif #endif end subroutine psb_camnv - subroutine psb_camnm(ictxt,dat,root) + subroutine psb_camnm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -527,96 +423,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,icomm,info) end if endif #endif end subroutine psb_camnm - - subroutine psb_camns_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_camns_ec - - subroutine psb_camnv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_camnv_ec - - subroutine psb_camnm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_camnm_ec - - ! ! BCAST Broadcast ! - subroutine psb_cbcasts(ictxt,dat,root) + subroutine psb_cbcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -624,29 +471,29 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - call mpi_bcast(dat,1,psb_mpi_c_spk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,psb_mpi_c_spk_,root_,icomm,info) #endif end subroutine psb_cbcasts - subroutine psb_cbcastv(ictxt,dat,root) + subroutine psb_cbcastv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -655,28 +502,27 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,icomm,info) #endif end subroutine psb_cbcastv - subroutine psb_cbcastm(ictxt,dat,root) + subroutine psb_cbcastm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -685,85 +531,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,icomm,info) #endif end subroutine psb_cbcastm - - subroutine psb_cbcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_cbcasts_ec - - subroutine psb_cbcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_cbcastv_ec - - subroutine psb_cbcastm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_cbcastm_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SCAN ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_cscan_sums(ictxt,dat) + subroutine psb_cscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -771,23 +567,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat complex(psb_spk_) :: dat_ integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo, icomm - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_scan(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,icomm,minfo) dat = dat_ #endif end subroutine psb_cscan_sums - subroutine psb_cexscan_sums(ictxt,dat) + subroutine psb_cexscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -795,7 +590,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat complex(psb_spk_) :: dat_ integer(psb_ipk_) :: iam, np, info @@ -803,8 +598,8 @@ contains #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_exscan(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,icomm,minfo) dat = dat_ #else @@ -812,7 +607,7 @@ contains #endif end subroutine psb_cexscan_sums - subroutine psb_cscan_sumv(ictxt,dat,root) + subroutine psb_cscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -821,7 +616,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -830,8 +625,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -839,7 +634,7 @@ contains #endif end subroutine psb_cscan_sumv - subroutine psb_cexscan_sumv(ictxt,dat,root) + subroutine psb_cexscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -848,7 +643,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -857,8 +652,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -869,18 +664,17 @@ contains end subroutine psb_cexscan_sumv subroutine psb_c_simple_a2av(valsnd,sdsz,bsdindx,& - & valrcv,rvsz,brvindx,ictxt,info) + & valrcv,rvsz,brvindx,ctxt,info) use psi_c_p2p_mod implicit none complex(psb_spk_), intent(in) :: valsnd(:) complex(psb_spk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then idx = bsdindx(ip+1) - call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + call psb_snd(ctxt,valsnd(idx+1:idx+sz),ip) end if end do @@ -899,14 +693,14 @@ contains sz = rvsz(ip+1) if (sz > 0) then idx = brvindx(ip+1) - call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + call psb_rcv(ctxt,valrcv(idx+1:idx+sz),ip) end if end do end subroutine psb_c_simple_a2av subroutine psb_c_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -919,7 +713,7 @@ contains complex(psb_spk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -927,9 +721,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_complex_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -961,7 +755,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_complex_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& @@ -989,7 +783,7 @@ contains end subroutine psb_c_m_simple_triad_a2av subroutine psb_c_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1002,7 +796,7 @@ contains complex(psb_spk_), intent(out) :: valrcv(:) integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1010,9 +804,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_complex_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1044,7 +838,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_complex_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& diff --git a/base/modules/penv/psi_c_p2p_mod.F90 b/base/modules/penv/psi_c_p2p_mod.F90 index f732c808..245a98b6 100644 --- a/base/modules/penv/psi_c_p2p_mod.F90 +++ b/base/modules/penv/psi_c_p2p_mod.F90 @@ -32,22 +32,18 @@ module psi_c_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_snd - module procedure psb_csnds, psb_csndv, psb_csndm, & - & psb_csnds_ec, psb_csndv_ec, psb_csndm_ec + module procedure psb_csnds, psb_csndv, psb_csndm end interface interface psb_rcv - module procedure psb_crcvs, psb_crcvv, psb_crcvm, & - & psb_crcvs_ec, psb_crcvv_ec, psb_crcvm_ec + module procedure psb_crcvs, psb_crcvv, psb_crcvm end interface contains - subroutine psb_csnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_csnds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -55,7 +51,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst complex(psb_spk_), allocatable :: dat_(:) @@ -65,12 +61,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_complex_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_csnds - subroutine psb_csndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_csndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -79,23 +74,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_complex_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_csndv - subroutine psb_csndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_csndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -104,13 +98,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m complex(psb_spk_), allocatable :: dat_(:) integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else @@ -128,12 +122,11 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_complex_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_csndm - subroutine psb_crcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_crcvs(ctxt,dat,src) #ifdef MPI_MOD use mpi #endif @@ -141,21 +134,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,psb_mpi_c_spk_,src,psb_complex_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_crcvs - subroutine psb_crcvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_crcvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -164,22 +157,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_crcvv - subroutine psb_crcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_crcvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -188,14 +181,14 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_spk_), intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m complex(psb_spk_), allocatable :: dat_(:) integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_mpk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else @@ -205,11 +198,13 @@ contains n_ = size(dat,2) call mpi_type_vector(n_,m_,ld,psb_mpi_c_spk_,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + icomm = psb_get_mpi_comm(ctxt) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_complex_tag,ictxt,status,info) + & psb_complex_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else - call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -218,90 +213,4 @@ contains #endif end subroutine psb_crcvm - - subroutine psb_csnds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_csnds_ec - - subroutine psb_csndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_csndv_ec - - subroutine psb_csndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_csndm_ec - - subroutine psb_crcvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_crcvs_ec - - subroutine psb_crcvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_crcvv_ec - - subroutine psb_crcvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_crcvm_ec - - end module psi_c_p2p_mod diff --git a/base/modules/penv/psi_collective_mod.F90 b/base/modules/penv/psi_collective_mod.F90 index 0fb37241..2a669c53 100644 --- a/base/modules/penv/psi_collective_mod.F90 +++ b/base/modules/penv/psi_collective_mod.F90 @@ -40,23 +40,19 @@ module psi_collective_mod interface psb_bcast module procedure psb_hbcasts, psb_hbcastv,& - & psb_hbcasts_ec, psb_hbcastv_ec,& - & psb_lbcasts, psb_lbcastv, & - & psb_lbcasts_ec, psb_lbcastv_ec + & psb_lbcasts, psb_lbcastv end interface psb_bcast #if defined(SHORT_INTEGERS) interface psb_sum - module procedure psb_i2sums, psb_i2sumv, psb_i2summ, & - & psb_i2sums_ec, psb_i2sumv_ec, psb_i2summ_ec + module procedure psb_i2sums, psb_i2sumv, psb_i2summ end interface psb_sum #endif contains - - subroutine psb_hbcasts(ictxt,dat,root,length) + subroutine psb_hbcasts(ctxt,dat,root,length) #ifdef MPI_MOD use mpi #endif @@ -64,11 +60,11 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt character(len=*), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root,length - integer(psb_mpk_) :: iam, np, root_,length_,info + integer(psb_mpk_) :: iam, np, root_,length_,info, icomm #if !defined(SERIAL_MPI) if (present(root)) then @@ -82,14 +78,14 @@ contains length_ = len(dat) endif - call psb_info(ictxt,iam,np) - - call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,length_,MPI_CHARACTER,root_,icomm,info) #endif end subroutine psb_hbcasts - subroutine psb_hbcastv(ictxt,dat,root) + subroutine psb_hbcastv(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -97,11 +93,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt character(len=*), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root - integer(psb_mpk_) :: iam, np, root_,length_,info, size_ + integer(psb_mpk_) :: iam, np, root_, icomm + integer(psb_mpk_) :: length_,info, size_ #if !defined(SERIAL_MPI) if (present(root)) then @@ -112,48 +109,14 @@ contains length_ = len(dat) size_ = size(dat) - call psb_info(ictxt,iam,np) - - call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,icomm,info) #endif end subroutine psb_hbcastv - subroutine psb_hbcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - character(len=*), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_hbcasts_ec - - subroutine psb_hbcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - character(len=*), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_hbcastv_ec - - - - subroutine psb_lbcasts(ictxt,dat,root) + subroutine psb_lbcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -161,11 +124,11 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root - integer(psb_mpk_) :: iam, np, root_,info + integer(psb_mpk_) :: iam, np, root_,info, icomm #if !defined(SERIAL_MPI) if (present(root)) then @@ -174,13 +137,14 @@ contains root_ = psb_root_ endif - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,MPI_LOGICAL,root_,icomm,info) #endif end subroutine psb_lbcasts - subroutine psb_lallreduceand(ictxt,dat,rec) + subroutine psb_lallreduceand(ctxt,dat,rec) #ifdef MPI_MOD use mpi #endif @@ -188,25 +152,26 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(inout) :: dat logical, intent(inout), optional :: rec - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) if (present(rec)) then - call mpi_allreduce(dat,rec,1,MPI_LOGICAL,MPI_LAND,ictxt,info) + call mpi_allreduce(dat,rec,1,MPI_LOGICAL,MPI_LAND,icomm,info) else - call mpi_allreduce(MPI_IN_PLACE,dat,1,MPI_LOGICAL,MPI_LAND,ictxt,info) + call mpi_allreduce(MPI_IN_PLACE,dat,1,MPI_LOGICAL,MPI_LAND,icomm,info) endif #endif end subroutine psb_lallreduceand - subroutine psb_lbcastv(ictxt,dat,root) + subroutine psb_lbcastv(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -214,11 +179,11 @@ end subroutine psb_lallreduceand #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root - integer(psb_mpk_) :: iam, np, root_,info + integer(psb_mpk_) :: iam, np, root_,info, icomm #if !defined(SERIAL_MPI) if (present(root)) then @@ -226,50 +191,15 @@ end subroutine psb_lallreduceand else root_ = psb_root_ endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,icomm,info) #endif end subroutine psb_lbcastv - - subroutine psb_lbcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - logical, intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_lbcasts_ec - - subroutine psb_lbcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - logical, intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_lbcastv_ec - - - #if defined(SHORT_INTEGERS) - subroutine psb_i2sums(ictxt,dat,root) + subroutine psb_i2sums(ctxt,dat,root) #ifdef MPI_MOD use mpi @@ -278,35 +208,36 @@ end subroutine psb_lallreduceand #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_i2sums - subroutine psb_i2sumv(ictxt,dat,root) + subroutine psb_i2sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -315,41 +246,42 @@ end subroutine psb_lallreduceand #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_=dat if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_i2pk_,mpi_sum,ictxt,info) + & psb_mpi_i2pk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) else - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_i2sumv - subroutine psb_i2summ(ictxt,dat,root) + subroutine psb_i2summ(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -358,88 +290,41 @@ end subroutine psb_lallreduceand #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_=dat if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_i2pk_,mpi_sum,ictxt,info) + & psb_mpi_i2pk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) else - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_i2summ - subroutine psb_i2sums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2sums_ec - - subroutine psb_i2sumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2sumv_ec - - subroutine psb_i2summ_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2summ_ec - #endif end module psi_collective_mod diff --git a/base/modules/penv/psi_comm_buffers_mod.F90 b/base/modules/penv/psi_comm_buffers_mod.F90 deleted file mode 100644 index c9c484e8..00000000 --- a/base/modules/penv/psi_comm_buffers_mod.F90 +++ /dev/null @@ -1,616 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! 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 PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific 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 PSBLAS 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. -! -! -#if defined(SERIAL_MPI) -! Provide a fake mpi module just to keep the compiler(s) happy. -module mpi - use psb_const_mod - integer(psb_mpk_), parameter :: mpi_success = 0 - integer(psb_mpk_), parameter :: mpi_request_null = 0 - integer(psb_mpk_), parameter :: mpi_status_size = 1 - integer(psb_mpk_), parameter :: mpi_integer = 1 - integer(psb_mpk_), parameter :: mpi_integer8 = 2 - integer(psb_mpk_), parameter :: mpi_real = 3 - integer(psb_mpk_), parameter :: mpi_double_precision = 4 - integer(psb_mpk_), parameter :: mpi_complex = 5 - integer(psb_mpk_), parameter :: mpi_double_complex = 6 - integer(psb_mpk_), parameter :: mpi_character = 7 - integer(psb_mpk_), parameter :: mpi_logical = 8 - integer(psb_mpk_), parameter :: mpi_integer2 = 9 - integer(psb_mpk_), parameter :: mpi_comm_null = -1 - integer(psb_mpk_), parameter :: mpi_comm_world = 1 - - real(psb_dpk_), external :: mpi_wtime -end module mpi -#endif - -module psi_comm_buffers_mod - use psb_const_mod - - integer(psb_mpk_), parameter:: psb_int_tag = 543987 - integer(psb_mpk_), parameter:: psb_real_tag = psb_int_tag + 1 - integer(psb_mpk_), parameter:: psb_double_tag = psb_real_tag + 1 - integer(psb_mpk_), parameter:: psb_complex_tag = psb_double_tag + 1 - integer(psb_mpk_), parameter:: psb_dcomplex_tag = psb_complex_tag + 1 - integer(psb_mpk_), parameter:: psb_logical_tag = psb_dcomplex_tag + 1 - integer(psb_mpk_), parameter:: psb_char_tag = psb_logical_tag + 1 - integer(psb_mpk_), parameter:: psb_int8_tag = psb_char_tag + 1 - integer(psb_mpk_), parameter:: psb_int2_tag = psb_int8_tag + 1 - integer(psb_mpk_), parameter:: psb_int4_tag = psb_int2_tag + 1 - integer(psb_mpk_), parameter:: psb_long_tag = psb_int4_tag + 1 - - integer(psb_mpk_), parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_double_swap_tag = psb_double_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_complex_swap_tag = psb_complex_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_dcomplex_swap_tag = psb_dcomplex_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_logical_swap_tag = psb_logical_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_char_swap_tag = psb_char_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_int2_swap_tag = psb_int2_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_int4_swap_tag = psb_int4_tag + psb_int_tag - integer(psb_mpk_), parameter:: psb_long_swap_tag = psb_long_tag + psb_int_tag - - - - integer(psb_mpk_), private, parameter:: psb_int_type = 987543 - integer(psb_mpk_), private, parameter:: psb_real_type = psb_int_type + 1 - integer(psb_mpk_), private, parameter:: psb_double_type = psb_real_type + 1 - integer(psb_mpk_), private, parameter:: psb_complex_type = psb_double_type + 1 - integer(psb_mpk_), private, parameter:: psb_dcomplex_type = psb_complex_type + 1 - integer(psb_mpk_), private, parameter:: psb_logical_type = psb_dcomplex_type + 1 - integer(psb_mpk_), private, parameter:: psb_char_type = psb_logical_type + 1 - integer(psb_mpk_), private, parameter:: psb_int8_type = psb_char_type + 1 - integer(psb_mpk_), private, parameter:: psb_int2_type = psb_int8_type + 1 - integer(psb_mpk_), private, parameter:: psb_int4_type = psb_int2_type + 1 - integer(psb_mpk_), private, parameter:: psb_long_type = psb_int4_type + 1 - - - type psb_buffer_node - integer(psb_mpk_) :: request - integer(psb_mpk_) :: icontxt - integer(psb_mpk_) :: buffer_type - integer(psb_epk_), allocatable :: int8buf(:) - integer(psb_i2pk_), allocatable :: int2buf(:) - integer(psb_mpk_), allocatable :: int4buf(:) - real(psb_spk_), allocatable :: realbuf(:) - real(psb_dpk_), allocatable :: doublebuf(:) - complex(psb_spk_), allocatable :: complexbuf(:) - complex(psb_dpk_), allocatable :: dcomplbuf(:) - logical, allocatable :: logbuf(:) - character(len=1), allocatable :: charbuf(:) - type(psb_buffer_node), pointer :: prev=>null(), next=>null() - end type psb_buffer_node - - type psb_buffer_queue - type(psb_buffer_node), pointer :: head=>null(), tail=>null() - end type psb_buffer_queue - - - interface psi_snd - module procedure& - & psi_msnd, psi_esnd,& - & psi_ssnd, psi_dsnd,& - & psi_csnd, psi_zsnd,& - & psi_logsnd, psi_hsnd,& - & psi_i2snd - end interface - -contains - - subroutine psb_init_queue(mesg_queue,info) - implicit none - type(psb_buffer_queue), intent(inout) :: mesg_queue - integer(psb_ipk_), intent(out) :: info - - info = 0 - if ((.not.associated(mesg_queue%head)).and.& - & (.not.associated(mesg_queue%tail))) then - ! Nothing to do - return - end if - - if ((.not.associated(mesg_queue%head)).or.& - & (.not.associated(mesg_queue%tail))) then - ! If we are here one is associated, the other is not. - ! This is impossible. - info = -1 - write(psb_err_unit,*) 'Wrong status on init ' - return - end if - - end subroutine psb_init_queue - - subroutine psb_wait_buffer(node, info) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - type(psb_buffer_node), intent(inout) :: node - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: status(mpi_status_size),minfo - minfo = mpi_success - call mpi_wait(node%request,status,minfo) - info=minfo - end subroutine psb_wait_buffer - - subroutine psb_test_buffer(node, flag, info) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - type(psb_buffer_node), intent(inout) :: node - logical, intent(out) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: status(mpi_status_size), minfo - minfo = mpi_success -#if defined(SERIAL_MPI) - flag = .true. -#else - call mpi_test(node%request,flag,status,minfo) -#endif - info=minfo - end subroutine psb_test_buffer - - - subroutine psb_close_context(mesg_queue,icontxt) - type(psb_buffer_queue), intent(inout) :: mesg_queue - integer(psb_mpk_), intent(in) :: icontxt - integer(psb_ipk_) :: info - type(psb_buffer_node), pointer :: node, nextnode - - node => mesg_queue%head - do - if (.not.associated(node)) exit - nextnode => node%next - if (node%icontxt == icontxt) then - call psb_wait_buffer(node,info) - call psb_delete_node(mesg_queue,node) - end if - node => nextnode - end do - end subroutine psb_close_context - - subroutine psb_close_all_context(mesg_queue) - type(psb_buffer_queue), intent(inout) :: mesg_queue - type(psb_buffer_node), pointer :: node, nextnode - integer(psb_ipk_) :: info - - node => mesg_queue%head - do - if (.not.associated(node)) exit - nextnode => node%next - call psb_wait_buffer(node,info) - call psb_delete_node(mesg_queue,node) - node => nextnode - end do - end subroutine psb_close_all_context - - - subroutine psb_delete_node(mesg_queue,node) - type(psb_buffer_queue), intent(inout) :: mesg_queue - type(psb_buffer_node), pointer :: node - type(psb_buffer_node), pointer :: prevnode - - if (.not.associated(node)) then - return - end if - prevnode => node%prev - if (associated(mesg_queue%head,node)) mesg_queue%head => node%next - if (associated(mesg_queue%tail,node)) mesg_queue%tail => prevnode - if (associated(prevnode)) prevnode%next => node%next - if (associated(node%next)) node%next%prev => prevnode - deallocate(node) - - end subroutine psb_delete_node - - subroutine psb_insert_node(mesg_queue,node) - type(psb_buffer_queue), intent(inout) :: mesg_queue - type(psb_buffer_node), pointer :: node - - node%next => null() - node%prev => null() - if ((.not.associated(mesg_queue%head)).and.& - & (.not.associated(mesg_queue%tail))) then - mesg_Queue%head => node - mesg_queue%tail => node - return - end if - mesg_queue%tail%next => node - node%prev => mesg_queue%tail - mesg_queue%tail => node - - end subroutine psb_insert_node - - subroutine psb_test_nodes(mesg_queue) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node, nextnode - integer(psb_ipk_) :: info - logical :: flag - - node => mesg_queue%head - do - if (.not.associated(node)) exit - nextnode => node%next - call psb_test_buffer(node,flag,info) - if (flag) then - call psb_delete_node(mesg_queue,node) - end if - node => nextnode - end do - end subroutine psb_test_nodes - - ! !!!!!!!!!!!!!!!!! - ! - ! Inner send. Basic idea: - ! the input buffer is MOVE_ALLOCed - ! to a node in the mesg queue, then it is sent. - ! Thus the calling process should guarantee that - ! the buffer is dispensable, i.e. the user data - ! has already been copied. - ! - ! !!!!!!!!!!!!!!!!! - subroutine psi_msnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - integer(psb_mpk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_int_type - call move_alloc(buffer,node%int4buf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%int4buf,size(node%int4buf),psb_mpi_mpk_,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_msnd - - - subroutine psi_esnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - integer(psb_epk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_int8_type - call move_alloc(buffer,node%int8buf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%int8buf,size(node%int8buf),psb_mpi_epk_,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_esnd - - subroutine psi_i2snd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - integer(psb_i2pk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_int2_type - call move_alloc(buffer,node%int2buf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%int2buf,size(node%int2buf),psb_mpi_i2pk_,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_i2snd - - subroutine psi_ssnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - real(psb_spk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_real_type - call move_alloc(buffer,node%realbuf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%realbuf,size(node%realbuf),psb_mpi_r_spk_,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_ssnd - - subroutine psi_dsnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - real(psb_dpk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_double_type - call move_alloc(buffer,node%doublebuf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%doublebuf,size(node%doublebuf),psb_mpi_r_dpk_,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_dsnd - - subroutine psi_csnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - complex(psb_spk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_complex_type - call move_alloc(buffer,node%complexbuf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%complexbuf,size(node%complexbuf),psb_mpi_c_spk_,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_csnd - - subroutine psi_zsnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - complex(psb_dpk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_dcomplex_type - call move_alloc(buffer,node%dcomplbuf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%dcomplbuf,size(node%dcomplbuf),psb_mpi_c_dpk_,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_zsnd - - - subroutine psi_logsnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - logical, allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_logical_type - call move_alloc(buffer,node%logbuf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%logbuf,size(node%logbuf),mpi_logical,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_logsnd - - - subroutine psi_hsnd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - character(len=1), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_ipk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_char_type - call move_alloc(buffer,node%charbuf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%charbuf,size(node%charbuf),mpi_character,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_hsnd - - -end module psi_comm_buffers_mod - diff --git a/base/modules/penv/psi_d_collective_mod.F90 b/base/modules/penv/psi_d_collective_mod.F90 index eb848a9f..12d5f38b 100644 --- a/base/modules/penv/psi_d_collective_mod.F90 +++ b/base/modules/penv/psi_d_collective_mod.F90 @@ -31,42 +31,33 @@ ! module psi_d_collective_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_max - module procedure psb_dmaxs, psb_dmaxv, psb_dmaxm, & - & psb_dmaxs_ec, psb_dmaxv_ec, psb_dmaxm_ec + module procedure psb_dmaxs, psb_dmaxv, psb_dmaxm end interface interface psb_min - module procedure psb_dmins, psb_dminv, psb_dminm, & - & psb_dmins_ec, psb_dminv_ec, psb_dminm_ec + module procedure psb_dmins, psb_dminv, psb_dminm end interface psb_min interface psb_nrm2 - module procedure psb_d_nrm2s, psb_d_nrm2v, & - & psb_d_nrm2s_ec, psb_d_nrm2v_ec + module procedure psb_d_nrm2s, psb_d_nrm2v end interface psb_nrm2 interface psb_sum - module procedure psb_dsums, psb_dsumv, psb_dsumm, & - & psb_dsums_ec, psb_dsumv_ec, psb_dsumm_ec + module procedure psb_dsums, psb_dsumv, psb_dsumm end interface interface psb_amx - module procedure psb_damxs, psb_damxv, psb_damxm, & - & psb_damxs_ec, psb_damxv_ec, psb_damxm_ec + module procedure psb_damxs, psb_damxv, psb_damxm end interface interface psb_amn - module procedure psb_damns, psb_damnv, psb_damnm, & - & psb_damns_ec, psb_damnv_ec, psb_damnm_ec + module procedure psb_damns, psb_damnv, psb_damnm end interface - interface psb_bcast - module procedure psb_dbcasts, psb_dbcastv, psb_dbcastm, & - & psb_dbcasts_ec, psb_dbcastv_ec, psb_dbcastm_ec + module procedure psb_dbcasts, psb_dbcastv, psb_dbcastm end interface psb_bcast interface psb_scan_sum @@ -85,7 +76,6 @@ module psi_d_collective_mod module procedure psb_d_e_simple_triad_a2av, psb_d_m_simple_triad_a2av end interface psb_simple_triad_a2av - contains ! !!!!!!!!!!!!!!!!!!!!!! @@ -101,7 +91,7 @@ contains ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_dmaxs(ictxt,dat,root) + subroutine psb_dmaxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -109,34 +99,33 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info - integer(psb_ipk_) :: iinfo - + integer(psb_mpk_) :: iam, np, info, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_dmaxs - subroutine psb_dmaxv(ictxt,dat,root) + subroutine psb_dmaxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -145,42 +134,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_dmaxv - subroutine psb_dmaxm(ictxt,dat,root) + subroutine psb_dmaxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -189,97 +179,48 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_dmaxm - - subroutine psb_dmaxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_dmaxs_ec - - subroutine psb_dmaxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_dmaxv_ec - - subroutine psb_dmaxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_dmaxm_ec - - ! ! MIN: Minimum Value ! - subroutine psb_dmins(ictxt,dat,root) + subroutine psb_dmins(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -287,34 +228,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_dmins - subroutine psb_dminv(ictxt,dat,root) + subroutine psb_dminv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -323,42 +265,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_dminv - subroutine psb_dminm(ictxt,dat,root) + subroutine psb_dminm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -367,98 +310,49 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_dminm - subroutine psb_dmins_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_dmins_ec - - subroutine psb_dminv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_dminv_ec - - subroutine psb_dminm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_dminm_ec - - - ! !!!!!!!!!!!! ! ! Norm 2, only for reals ! ! !!!!!!!!!!!! - subroutine psb_d_nrm2s(ictxt,dat,root) + subroutine psb_d_nrm2s(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -466,34 +360,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_d_nrm2s - subroutine psb_d_nrm2v(ictxt,dat,root) + subroutine psb_d_nrm2v(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -502,82 +397,51 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_dnrm2_op,ictxt,info) + & mpi_dnrm2_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_dnrm2_op,root_,ictxt,info) + & mpi_dnrm2_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,& - & mpi_dnrm2_op,root_,ictxt,info) + & mpi_dnrm2_op,root_,icomm,info) end if endif #endif end subroutine psb_d_nrm2v - subroutine psb_d_nrm2s_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_d_nrm2s_ec - - subroutine psb_d_nrm2v_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_d_nrm2v_ec - ! ! SUM ! - subroutine psb_dsums(ictxt,dat,root) + subroutine psb_dsums(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -585,34 +449,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_dsums - subroutine psb_dsumv(ictxt,dat,root) + subroutine psb_dsumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -621,42 +485,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_dsumv - subroutine psb_dsumm(ictxt,dat,root) + subroutine psb_dsumm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -665,95 +529,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_dsumm - subroutine psb_dsums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_dsums_ec - - subroutine psb_dsumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_dsumv_ec - - subroutine psb_dsumm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_dsumm_ec - - ! ! AMX: Maximum Absolute Value ! - subroutine psb_damxs(ictxt,dat,root) + subroutine psb_damxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -761,34 +577,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_damxs - subroutine psb_damxv(ictxt,dat,root) + subroutine psb_damxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -797,42 +613,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) end if endif #endif end subroutine psb_damxv - subroutine psb_damxm(ictxt,dat,root) + subroutine psb_damxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -841,96 +657,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,icomm,info) end if endif #endif end subroutine psb_damxm - - subroutine psb_damxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_damxs_ec - - subroutine psb_damxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_damxv_ec - - subroutine psb_damxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_damxm_ec - - ! ! AMN: Minimum Absolute Value ! - subroutine psb_damns(ictxt,dat,root) + subroutine psb_damns(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -938,34 +705,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_damns - subroutine psb_damnv(ictxt,dat,root) + subroutine psb_damnv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -974,42 +741,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) end if endif #endif end subroutine psb_damnv - subroutine psb_damnm(ictxt,dat,root) + subroutine psb_damnm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1018,96 +785,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,icomm,info) end if endif #endif end subroutine psb_damnm - - subroutine psb_damns_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_damns_ec - - subroutine psb_damnv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_damnv_ec - - subroutine psb_damnm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_damnm_ec - - ! ! BCAST Broadcast ! - subroutine psb_dbcasts(ictxt,dat,root) + subroutine psb_dbcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -1115,29 +833,29 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - call mpi_bcast(dat,1,psb_mpi_r_dpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,psb_mpi_r_dpk_,root_,icomm,info) #endif end subroutine psb_dbcasts - subroutine psb_dbcastv(ictxt,dat,root) + subroutine psb_dbcastv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1146,28 +864,27 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,icomm,info) #endif end subroutine psb_dbcastv - subroutine psb_dbcastm(ictxt,dat,root) + subroutine psb_dbcastm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1176,85 +893,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,icomm,info) #endif end subroutine psb_dbcastm - - subroutine psb_dbcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_dbcasts_ec - - subroutine psb_dbcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_dbcastv_ec - - subroutine psb_dbcastm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_dbcastm_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SCAN ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_dscan_sums(ictxt,dat) + subroutine psb_dscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1262,23 +929,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat real(psb_dpk_) :: dat_ integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo, icomm - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_scan(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,icomm,minfo) dat = dat_ #endif end subroutine psb_dscan_sums - subroutine psb_dexscan_sums(ictxt,dat) + subroutine psb_dexscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1286,7 +952,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat real(psb_dpk_) :: dat_ integer(psb_ipk_) :: iam, np, info @@ -1294,8 +960,8 @@ contains #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_exscan(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,icomm,minfo) dat = dat_ #else @@ -1303,7 +969,7 @@ contains #endif end subroutine psb_dexscan_sums - subroutine psb_dscan_sumv(ictxt,dat,root) + subroutine psb_dscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1312,7 +978,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1321,8 +987,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1330,7 +996,7 @@ contains #endif end subroutine psb_dscan_sumv - subroutine psb_dexscan_sumv(ictxt,dat,root) + subroutine psb_dexscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1339,7 +1005,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1348,8 +1014,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1360,18 +1026,17 @@ contains end subroutine psb_dexscan_sumv subroutine psb_d_simple_a2av(valsnd,sdsz,bsdindx,& - & valrcv,rvsz,brvindx,ictxt,info) + & valrcv,rvsz,brvindx,ctxt,info) use psi_d_p2p_mod implicit none real(psb_dpk_), intent(in) :: valsnd(:) real(psb_dpk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then idx = bsdindx(ip+1) - call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + call psb_snd(ctxt,valsnd(idx+1:idx+sz),ip) end if end do @@ -1390,14 +1055,14 @@ contains sz = rvsz(ip+1) if (sz > 0) then idx = brvindx(ip+1) - call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + call psb_rcv(ctxt,valrcv(idx+1:idx+sz),ip) end if end do end subroutine psb_d_simple_a2av subroutine psb_d_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1410,7 +1075,7 @@ contains real(psb_dpk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1418,9 +1083,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_double_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1452,7 +1117,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_double_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& @@ -1480,7 +1145,7 @@ contains end subroutine psb_d_m_simple_triad_a2av subroutine psb_d_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1493,7 +1158,7 @@ contains real(psb_dpk_), intent(out) :: valrcv(:) integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1501,9 +1166,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_double_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1535,7 +1200,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_double_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& diff --git a/base/modules/penv/psi_d_p2p_mod.F90 b/base/modules/penv/psi_d_p2p_mod.F90 index f59234f3..614c6802 100644 --- a/base/modules/penv/psi_d_p2p_mod.F90 +++ b/base/modules/penv/psi_d_p2p_mod.F90 @@ -32,22 +32,18 @@ module psi_d_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_snd - module procedure psb_dsnds, psb_dsndv, psb_dsndm, & - & psb_dsnds_ec, psb_dsndv_ec, psb_dsndm_ec + module procedure psb_dsnds, psb_dsndv, psb_dsndm end interface interface psb_rcv - module procedure psb_drcvs, psb_drcvv, psb_drcvm, & - & psb_drcvs_ec, psb_drcvv_ec, psb_drcvm_ec + module procedure psb_drcvs, psb_drcvv, psb_drcvm end interface contains - subroutine psb_dsnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_dsnds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -55,7 +51,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst real(psb_dpk_), allocatable :: dat_(:) @@ -65,12 +61,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_double_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_dsnds - subroutine psb_dsndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_dsndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -79,23 +74,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_double_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_dsndv - subroutine psb_dsndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_dsndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -104,13 +98,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m real(psb_dpk_), allocatable :: dat_(:) integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else @@ -128,12 +122,11 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_double_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_dsndm - subroutine psb_drcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_drcvs(ctxt,dat,src) #ifdef MPI_MOD use mpi #endif @@ -141,21 +134,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,psb_mpi_r_dpk_,src,psb_double_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_drcvs - subroutine psb_drcvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_drcvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -164,22 +157,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_drcvv - subroutine psb_drcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_drcvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -188,14 +181,14 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_dpk_), intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m real(psb_dpk_), allocatable :: dat_(:) integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_mpk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else @@ -205,11 +198,13 @@ contains n_ = size(dat,2) call mpi_type_vector(n_,m_,ld,psb_mpi_r_dpk_,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + icomm = psb_get_mpi_comm(ctxt) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_double_tag,ictxt,status,info) + & psb_double_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else - call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -218,90 +213,4 @@ contains #endif end subroutine psb_drcvm - - subroutine psb_dsnds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_dsnds_ec - - subroutine psb_dsndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_dsndv_ec - - subroutine psb_dsndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_dsndm_ec - - subroutine psb_drcvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_drcvs_ec - - subroutine psb_drcvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_drcvv_ec - - subroutine psb_drcvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_drcvm_ec - - end module psi_d_p2p_mod diff --git a/base/modules/penv/psi_e_collective_mod.F90 b/base/modules/penv/psi_e_collective_mod.F90 index 443f5f99..215446c0 100644 --- a/base/modules/penv/psi_e_collective_mod.F90 +++ b/base/modules/penv/psi_e_collective_mod.F90 @@ -31,38 +31,30 @@ ! module psi_e_collective_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_max - module procedure psb_emaxs, psb_emaxv, psb_emaxm, & - & psb_emaxs_ec, psb_emaxv_ec, psb_emaxm_ec + module procedure psb_emaxs, psb_emaxv, psb_emaxm end interface interface psb_min - module procedure psb_emins, psb_eminv, psb_eminm, & - & psb_emins_ec, psb_eminv_ec, psb_eminm_ec + module procedure psb_emins, psb_eminv, psb_eminm end interface psb_min interface psb_sum - module procedure psb_esums, psb_esumv, psb_esumm, & - & psb_esums_ec, psb_esumv_ec, psb_esumm_ec + module procedure psb_esums, psb_esumv, psb_esumm end interface interface psb_amx - module procedure psb_eamxs, psb_eamxv, psb_eamxm, & - & psb_eamxs_ec, psb_eamxv_ec, psb_eamxm_ec + module procedure psb_eamxs, psb_eamxv, psb_eamxm end interface interface psb_amn - module procedure psb_eamns, psb_eamnv, psb_eamnm, & - & psb_eamns_ec, psb_eamnv_ec, psb_eamnm_ec + module procedure psb_eamns, psb_eamnv, psb_eamnm end interface - interface psb_bcast - module procedure psb_ebcasts, psb_ebcastv, psb_ebcastm, & - & psb_ebcasts_ec, psb_ebcastv_ec, psb_ebcastm_ec + module procedure psb_ebcasts, psb_ebcastv, psb_ebcastm end interface psb_bcast interface psb_scan_sum @@ -81,7 +73,6 @@ module psi_e_collective_mod module procedure psb_e_e_simple_triad_a2av, psb_e_m_simple_triad_a2av end interface psb_simple_triad_a2av - contains ! !!!!!!!!!!!!!!!!!!!!!! @@ -97,7 +88,7 @@ contains ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_emaxs(ictxt,dat,root) + subroutine psb_emaxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -105,34 +96,33 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_) :: dat_ - integer(psb_mpk_) :: iam, np, info - integer(psb_ipk_) :: iinfo - + integer(psb_mpk_) :: iam, np, info, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_max,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_max,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_max,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_emaxs - subroutine psb_emaxv(ictxt,dat,root) + subroutine psb_emaxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -141,42 +131,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_emaxv - subroutine psb_emaxm(ictxt,dat,root) + subroutine psb_emaxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -185,97 +176,48 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_emaxm - - subroutine psb_emaxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_emaxs_ec - - subroutine psb_emaxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_emaxv_ec - - subroutine psb_emaxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_emaxm_ec - - ! ! MIN: Minimum Value ! - subroutine psb_emins(ictxt,dat,root) + subroutine psb_emins(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -283,34 +225,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_min,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_min,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_min,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_emins - subroutine psb_eminv(ictxt,dat,root) + subroutine psb_eminv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -319,42 +262,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_eminv - subroutine psb_eminm(ictxt,dat,root) + subroutine psb_eminm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -363,98 +307,49 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_eminm - subroutine psb_emins_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_emins_ec - - subroutine psb_eminv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_eminv_ec - - subroutine psb_eminm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_eminm_ec - - - ! ! SUM ! - subroutine psb_esums(ictxt,dat,root) + subroutine psb_esums(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -462,34 +357,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_esums - subroutine psb_esumv(ictxt,dat,root) + subroutine psb_esumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -498,42 +393,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_esumv - subroutine psb_esumm(ictxt,dat,root) + subroutine psb_esumm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -542,95 +437,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_esumm - subroutine psb_esums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_esums_ec - - subroutine psb_esumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_esumv_ec - - subroutine psb_esumm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_esumm_ec - - ! ! AMX: Maximum Absolute Value ! - subroutine psb_eamxs(ictxt,dat,root) + subroutine psb_eamxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -638,34 +485,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_eamx_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_eamx_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_eamxs - subroutine psb_eamxv(ictxt,dat,root) + subroutine psb_eamxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -674,42 +521,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) end if endif #endif end subroutine psb_eamxv - subroutine psb_eamxm(ictxt,dat,root) + subroutine psb_eamxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -718,96 +565,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,icomm,info) end if endif #endif end subroutine psb_eamxm - - subroutine psb_eamxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_eamxs_ec - - subroutine psb_eamxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_eamxv_ec - - subroutine psb_eamxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_eamxm_ec - - ! ! AMN: Minimum Absolute Value ! - subroutine psb_eamns(ictxt,dat,root) + subroutine psb_eamns(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -815,34 +613,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_eamn_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_eamn_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_eamns - subroutine psb_eamnv(ictxt,dat,root) + subroutine psb_eamnv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -851,42 +649,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) end if endif #endif end subroutine psb_eamnv - subroutine psb_eamnm(ictxt,dat,root) + subroutine psb_eamnm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -895,96 +693,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_epk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,icomm,info) end if endif #endif end subroutine psb_eamnm - - subroutine psb_eamns_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_eamns_ec - - subroutine psb_eamnv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_eamnv_ec - - subroutine psb_eamnm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_eamnm_ec - - ! ! BCAST Broadcast ! - subroutine psb_ebcasts(ictxt,dat,root) + subroutine psb_ebcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -992,29 +741,29 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - call mpi_bcast(dat,1,psb_mpi_epk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,psb_mpi_epk_,root_,icomm,info) #endif end subroutine psb_ebcasts - subroutine psb_ebcastv(ictxt,dat,root) + subroutine psb_ebcastv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1023,28 +772,27 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_epk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_epk_,root_,icomm,info) #endif end subroutine psb_ebcastv - subroutine psb_ebcastm(ictxt,dat,root) + subroutine psb_ebcastm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1053,85 +801,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_epk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_epk_,root_,icomm,info) #endif end subroutine psb_ebcastm - - subroutine psb_ebcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_ebcasts_ec - - subroutine psb_ebcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_ebcastv_ec - - subroutine psb_ebcastm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_ebcastm_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SCAN ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_escan_sums(ictxt,dat) + subroutine psb_escan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1139,23 +837,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_epk_) :: dat_ integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo, icomm - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_scan(dat,dat_,1,psb_mpi_epk_,mpi_sum,icomm,minfo) dat = dat_ #endif end subroutine psb_escan_sums - subroutine psb_eexscan_sums(ictxt,dat) + subroutine psb_eexscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1163,7 +860,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat integer(psb_epk_) :: dat_ integer(psb_ipk_) :: iam, np, info @@ -1171,8 +868,8 @@ contains #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_exscan(dat,dat_,1,psb_mpi_epk_,mpi_sum,icomm,minfo) dat = dat_ #else @@ -1180,7 +877,7 @@ contains #endif end subroutine psb_eexscan_sums - subroutine psb_escan_sumv(ictxt,dat,root) + subroutine psb_escan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1189,7 +886,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1198,8 +895,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1207,7 +904,7 @@ contains #endif end subroutine psb_escan_sumv - subroutine psb_eexscan_sumv(ictxt,dat,root) + subroutine psb_eexscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1216,7 +913,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1225,8 +922,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1237,18 +934,17 @@ contains end subroutine psb_eexscan_sumv subroutine psb_e_simple_a2av(valsnd,sdsz,bsdindx,& - & valrcv,rvsz,brvindx,ictxt,info) + & valrcv,rvsz,brvindx,ctxt,info) use psi_e_p2p_mod implicit none integer(psb_epk_), intent(in) :: valsnd(:) integer(psb_epk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then idx = bsdindx(ip+1) - call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + call psb_snd(ctxt,valsnd(idx+1:idx+sz),ip) end if end do @@ -1267,14 +963,14 @@ contains sz = rvsz(ip+1) if (sz > 0) then idx = brvindx(ip+1) - call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + call psb_rcv(ctxt,valrcv(idx+1:idx+sz),ip) end if end do end subroutine psb_e_simple_a2av subroutine psb_e_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1287,7 +983,7 @@ contains integer(psb_epk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1295,9 +991,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_int8_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1329,7 +1025,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_int8_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& @@ -1357,7 +1053,7 @@ contains end subroutine psb_e_m_simple_triad_a2av subroutine psb_e_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1370,7 +1066,7 @@ contains integer(psb_epk_), intent(out) :: valrcv(:) integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1378,9 +1074,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_int8_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1412,7 +1108,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_int8_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& diff --git a/base/modules/penv/psi_e_p2p_mod.F90 b/base/modules/penv/psi_e_p2p_mod.F90 index d72f4ee0..7c54bbf9 100644 --- a/base/modules/penv/psi_e_p2p_mod.F90 +++ b/base/modules/penv/psi_e_p2p_mod.F90 @@ -32,22 +32,18 @@ module psi_e_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_snd - module procedure psb_esnds, psb_esndv, psb_esndm, & - & psb_esnds_ec, psb_esndv_ec, psb_esndm_ec + module procedure psb_esnds, psb_esndv, psb_esndm end interface interface psb_rcv - module procedure psb_ercvs, psb_ercvv, psb_ercvm, & - & psb_ercvs_ec, psb_ercvv_ec, psb_ercvm_ec + module procedure psb_ercvs, psb_ercvv, psb_ercvm end interface contains - subroutine psb_esnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_esnds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -55,7 +51,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst integer(psb_epk_), allocatable :: dat_(:) @@ -65,12 +61,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int8_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_esnds - subroutine psb_esndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_esndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -79,23 +74,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst integer(psb_epk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int8_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_esndv - subroutine psb_esndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_esndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -104,13 +98,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m integer(psb_epk_), allocatable :: dat_(:) integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else @@ -128,12 +122,11 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int8_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_esndm - subroutine psb_ercvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_ercvs(ctxt,dat,src) #ifdef MPI_MOD use mpi #endif @@ -141,21 +134,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,psb_mpi_epk_,src,psb_int8_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_ercvs - subroutine psb_ercvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_ercvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -164,22 +157,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src integer(psb_epk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_ercvv - subroutine psb_ercvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_ercvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -188,14 +181,14 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m integer(psb_epk_), allocatable :: dat_(:) integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_mpk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else @@ -205,11 +198,13 @@ contains n_ = size(dat,2) call mpi_type_vector(n_,m_,ld,psb_mpi_epk_,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + icomm = psb_get_mpi_comm(ctxt) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_int8_tag,ictxt,status,info) + & psb_int8_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else - call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -218,90 +213,4 @@ contains #endif end subroutine psb_ercvm - - subroutine psb_esnds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_esnds_ec - - subroutine psb_esndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_esndv_ec - - subroutine psb_esndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_esndm_ec - - subroutine psb_ercvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_ercvs_ec - - subroutine psb_ercvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_ercvv_ec - - subroutine psb_ercvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_ercvm_ec - - end module psi_e_p2p_mod diff --git a/base/modules/penv/psi_i2_collective_mod.F90 b/base/modules/penv/psi_i2_collective_mod.F90 index 31a245b6..781653d4 100644 --- a/base/modules/penv/psi_i2_collective_mod.F90 +++ b/base/modules/penv/psi_i2_collective_mod.F90 @@ -31,38 +31,30 @@ ! module psi_i2_collective_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_max - module procedure psb_i2maxs, psb_i2maxv, psb_i2maxm, & - & psb_i2maxs_ec, psb_i2maxv_ec, psb_i2maxm_ec + module procedure psb_i2maxs, psb_i2maxv, psb_i2maxm end interface interface psb_min - module procedure psb_i2mins, psb_i2minv, psb_i2minm, & - & psb_i2mins_ec, psb_i2minv_ec, psb_i2minm_ec + module procedure psb_i2mins, psb_i2minv, psb_i2minm end interface psb_min interface psb_sum - module procedure psb_i2sums, psb_i2sumv, psb_i2summ, & - & psb_i2sums_ec, psb_i2sumv_ec, psb_i2summ_ec + module procedure psb_i2sums, psb_i2sumv, psb_i2summ end interface interface psb_amx - module procedure psb_i2amxs, psb_i2amxv, psb_i2amxm, & - & psb_i2amxs_ec, psb_i2amxv_ec, psb_i2amxm_ec + module procedure psb_i2amxs, psb_i2amxv, psb_i2amxm end interface interface psb_amn - module procedure psb_i2amns, psb_i2amnv, psb_i2amnm, & - & psb_i2amns_ec, psb_i2amnv_ec, psb_i2amnm_ec + module procedure psb_i2amns, psb_i2amnv, psb_i2amnm end interface - interface psb_bcast - module procedure psb_i2bcasts, psb_i2bcastv, psb_i2bcastm, & - & psb_i2bcasts_ec, psb_i2bcastv_ec, psb_i2bcastm_ec + module procedure psb_i2bcasts, psb_i2bcastv, psb_i2bcastm end interface psb_bcast interface psb_scan_sum @@ -81,7 +73,6 @@ module psi_i2_collective_mod module procedure psb_i2_e_simple_triad_a2av, psb_i2_m_simple_triad_a2av end interface psb_simple_triad_a2av - contains ! !!!!!!!!!!!!!!!!!!!!!! @@ -97,7 +88,7 @@ contains ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_i2maxs(ictxt,dat,root) + subroutine psb_i2maxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -105,34 +96,33 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_) :: dat_ - integer(psb_mpk_) :: iam, np, info - integer(psb_ipk_) :: iinfo - + integer(psb_mpk_) :: iam, np, info, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_max,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_max,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_max,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_i2maxs - subroutine psb_i2maxv(ictxt,dat,root) + subroutine psb_i2maxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -141,42 +131,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_i2maxv - subroutine psb_i2maxm(ictxt,dat,root) + subroutine psb_i2maxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -185,97 +176,48 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_i2maxm - - subroutine psb_i2maxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_i2maxs_ec - - subroutine psb_i2maxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_i2maxv_ec - - subroutine psb_i2maxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_i2maxm_ec - - ! ! MIN: Minimum Value ! - subroutine psb_i2mins(ictxt,dat,root) + subroutine psb_i2mins(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -283,34 +225,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_min,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_min,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_min,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_i2mins - subroutine psb_i2minv(ictxt,dat,root) + subroutine psb_i2minv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -319,42 +262,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_i2minv - subroutine psb_i2minm(ictxt,dat,root) + subroutine psb_i2minm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -363,98 +307,49 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_i2minm - subroutine psb_i2mins_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_i2mins_ec - - subroutine psb_i2minv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_i2minv_ec - - subroutine psb_i2minm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_i2minm_ec - - - ! ! SUM ! - subroutine psb_i2sums(ictxt,dat,root) + subroutine psb_i2sums(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -462,34 +357,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_i2sums - subroutine psb_i2sumv(ictxt,dat,root) + subroutine psb_i2sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -498,42 +393,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_i2sumv - subroutine psb_i2summ(ictxt,dat,root) + subroutine psb_i2summ(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -542,95 +437,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_i2summ - subroutine psb_i2sums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2sums_ec - - subroutine psb_i2sumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2sumv_ec - - subroutine psb_i2summ_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2summ_ec - - ! ! AMX: Maximum Absolute Value ! - subroutine psb_i2amxs(ictxt,dat,root) + subroutine psb_i2amxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -638,34 +485,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amx_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amx_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_i2amxs - subroutine psb_i2amxv(ictxt,dat,root) + subroutine psb_i2amxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -674,42 +521,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) end if endif #endif end subroutine psb_i2amxv - subroutine psb_i2amxm(ictxt,dat,root) + subroutine psb_i2amxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -718,96 +565,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,icomm,info) end if endif #endif end subroutine psb_i2amxm - - subroutine psb_i2amxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_i2amxs_ec - - subroutine psb_i2amxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_i2amxv_ec - - subroutine psb_i2amxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_i2amxm_ec - - ! ! AMN: Minimum Absolute Value ! - subroutine psb_i2amns(ictxt,dat,root) + subroutine psb_i2amns(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -815,34 +613,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amn_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amn_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_i2amns - subroutine psb_i2amnv(ictxt,dat,root) + subroutine psb_i2amnv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -851,42 +649,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) end if endif #endif end subroutine psb_i2amnv - subroutine psb_i2amnm(ictxt,dat,root) + subroutine psb_i2amnm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -895,96 +693,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_i2pk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,icomm,info) end if endif #endif end subroutine psb_i2amnm - - subroutine psb_i2amns_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_i2amns_ec - - subroutine psb_i2amnv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_i2amnv_ec - - subroutine psb_i2amnm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_i2amnm_ec - - ! ! BCAST Broadcast ! - subroutine psb_i2bcasts(ictxt,dat,root) + subroutine psb_i2bcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -992,29 +741,29 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - call mpi_bcast(dat,1,psb_mpi_i2pk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,psb_mpi_i2pk_,root_,icomm,info) #endif end subroutine psb_i2bcasts - subroutine psb_i2bcastv(ictxt,dat,root) + subroutine psb_i2bcastv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1023,28 +772,27 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_i2pk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_i2pk_,root_,icomm,info) #endif end subroutine psb_i2bcastv - subroutine psb_i2bcastm(ictxt,dat,root) + subroutine psb_i2bcastm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1053,85 +801,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_i2pk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_i2pk_,root_,icomm,info) #endif end subroutine psb_i2bcastm - - subroutine psb_i2bcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_i2bcasts_ec - - subroutine psb_i2bcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_i2bcastv_ec - - subroutine psb_i2bcastm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_i2bcastm_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SCAN ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_i2scan_sums(ictxt,dat) + subroutine psb_i2scan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1139,23 +837,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_i2pk_) :: dat_ integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo, icomm - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_scan(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,icomm,minfo) dat = dat_ #endif end subroutine psb_i2scan_sums - subroutine psb_i2exscan_sums(ictxt,dat) + subroutine psb_i2exscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1163,7 +860,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_i2pk_) :: dat_ integer(psb_ipk_) :: iam, np, info @@ -1171,8 +868,8 @@ contains #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_exscan(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,icomm,minfo) dat = dat_ #else @@ -1180,7 +877,7 @@ contains #endif end subroutine psb_i2exscan_sums - subroutine psb_i2scan_sumv(ictxt,dat,root) + subroutine psb_i2scan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1189,7 +886,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1198,8 +895,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1207,7 +904,7 @@ contains #endif end subroutine psb_i2scan_sumv - subroutine psb_i2exscan_sumv(ictxt,dat,root) + subroutine psb_i2exscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1216,7 +913,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1225,8 +922,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1237,18 +934,17 @@ contains end subroutine psb_i2exscan_sumv subroutine psb_i2_simple_a2av(valsnd,sdsz,bsdindx,& - & valrcv,rvsz,brvindx,ictxt,info) + & valrcv,rvsz,brvindx,ctxt,info) use psi_i2_p2p_mod implicit none integer(psb_i2pk_), intent(in) :: valsnd(:) integer(psb_i2pk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then idx = bsdindx(ip+1) - call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + call psb_snd(ctxt,valsnd(idx+1:idx+sz),ip) end if end do @@ -1267,14 +963,14 @@ contains sz = rvsz(ip+1) if (sz > 0) then idx = brvindx(ip+1) - call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + call psb_rcv(ctxt,valrcv(idx+1:idx+sz),ip) end if end do end subroutine psb_i2_simple_a2av subroutine psb_i2_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1287,7 +983,7 @@ contains integer(psb_i2pk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1295,9 +991,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_int2_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1329,7 +1025,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_int2_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& @@ -1357,7 +1053,7 @@ contains end subroutine psb_i2_m_simple_triad_a2av subroutine psb_i2_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1370,7 +1066,7 @@ contains integer(psb_i2pk_), intent(out) :: valrcv(:) integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1378,9 +1074,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_int2_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1412,7 +1108,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_int2_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& diff --git a/base/modules/penv/psi_i2_p2p_mod.F90 b/base/modules/penv/psi_i2_p2p_mod.F90 index 84bf7712..ad80cb44 100644 --- a/base/modules/penv/psi_i2_p2p_mod.F90 +++ b/base/modules/penv/psi_i2_p2p_mod.F90 @@ -32,22 +32,18 @@ module psi_i2_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_snd - module procedure psb_i2snds, psb_i2sndv, psb_i2sndm, & - & psb_i2snds_ec, psb_i2sndv_ec, psb_i2sndm_ec + module procedure psb_i2snds, psb_i2sndv, psb_i2sndm end interface interface psb_rcv - module procedure psb_i2rcvs, psb_i2rcvv, psb_i2rcvm, & - & psb_i2rcvs_ec, psb_i2rcvv_ec, psb_i2rcvm_ec + module procedure psb_i2rcvs, psb_i2rcvv, psb_i2rcvm end interface contains - subroutine psb_i2snds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_i2snds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -55,7 +51,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst integer(psb_i2pk_), allocatable :: dat_(:) @@ -65,12 +61,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int2_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_i2snds - subroutine psb_i2sndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_i2sndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -79,23 +74,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int2_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_i2sndv - subroutine psb_i2sndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_i2sndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -104,13 +98,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m integer(psb_i2pk_), allocatable :: dat_(:) integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else @@ -128,12 +122,11 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int2_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_i2sndm - subroutine psb_i2rcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_i2rcvs(ctxt,dat,src) #ifdef MPI_MOD use mpi #endif @@ -141,21 +134,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,psb_mpi_i2pk_,src,psb_int2_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_i2rcvs - subroutine psb_i2rcvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_i2rcvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -164,22 +157,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src integer(psb_i2pk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_i2rcvv - subroutine psb_i2rcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_i2rcvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -188,14 +181,14 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_i2pk_), intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m integer(psb_i2pk_), allocatable :: dat_(:) integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_mpk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else @@ -205,11 +198,13 @@ contains n_ = size(dat,2) call mpi_type_vector(n_,m_,ld,psb_mpi_i2pk_,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + icomm = psb_get_mpi_comm(ctxt) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_int2_tag,ictxt,status,info) + & psb_int2_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else - call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -218,90 +213,4 @@ contains #endif end subroutine psb_i2rcvm - - subroutine psb_i2snds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_i2snds_ec - - subroutine psb_i2sndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_i2sndv_ec - - subroutine psb_i2sndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_i2sndm_ec - - subroutine psb_i2rcvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_i2rcvs_ec - - subroutine psb_i2rcvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_i2rcvv_ec - - subroutine psb_i2rcvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_i2pk_), intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_i2rcvm_ec - - end module psi_i2_p2p_mod diff --git a/base/modules/penv/psi_m_collective_mod.F90 b/base/modules/penv/psi_m_collective_mod.F90 index 8badcf87..8fdea824 100644 --- a/base/modules/penv/psi_m_collective_mod.F90 +++ b/base/modules/penv/psi_m_collective_mod.F90 @@ -31,38 +31,30 @@ ! module psi_m_collective_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_max - module procedure psb_mmaxs, psb_mmaxv, psb_mmaxm, & - & psb_mmaxs_ec, psb_mmaxv_ec, psb_mmaxm_ec + module procedure psb_mmaxs, psb_mmaxv, psb_mmaxm end interface interface psb_min - module procedure psb_mmins, psb_mminv, psb_mminm, & - & psb_mmins_ec, psb_mminv_ec, psb_mminm_ec + module procedure psb_mmins, psb_mminv, psb_mminm end interface psb_min interface psb_sum - module procedure psb_msums, psb_msumv, psb_msumm, & - & psb_msums_ec, psb_msumv_ec, psb_msumm_ec + module procedure psb_msums, psb_msumv, psb_msumm end interface interface psb_amx - module procedure psb_mamxs, psb_mamxv, psb_mamxm, & - & psb_mamxs_ec, psb_mamxv_ec, psb_mamxm_ec + module procedure psb_mamxs, psb_mamxv, psb_mamxm end interface interface psb_amn - module procedure psb_mamns, psb_mamnv, psb_mamnm, & - & psb_mamns_ec, psb_mamnv_ec, psb_mamnm_ec + module procedure psb_mamns, psb_mamnv, psb_mamnm end interface - interface psb_bcast - module procedure psb_mbcasts, psb_mbcastv, psb_mbcastm, & - & psb_mbcasts_ec, psb_mbcastv_ec, psb_mbcastm_ec + module procedure psb_mbcasts, psb_mbcastv, psb_mbcastm end interface psb_bcast interface psb_scan_sum @@ -81,7 +73,6 @@ module psi_m_collective_mod module procedure psb_m_e_simple_triad_a2av, psb_m_m_simple_triad_a2av end interface psb_simple_triad_a2av - contains ! !!!!!!!!!!!!!!!!!!!!!! @@ -97,7 +88,7 @@ contains ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_mmaxs(ictxt,dat,root) + subroutine psb_mmaxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -105,34 +96,33 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info - integer(psb_ipk_) :: iinfo - + integer(psb_mpk_) :: iam, np, info, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_max,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_max,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_max,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_mmaxs - subroutine psb_mmaxv(ictxt,dat,root) + subroutine psb_mmaxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -141,42 +131,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_mmaxv - subroutine psb_mmaxm(ictxt,dat,root) + subroutine psb_mmaxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -185,97 +176,48 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_mmaxm - - subroutine psb_mmaxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_mmaxs_ec - - subroutine psb_mmaxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_mmaxv_ec - - subroutine psb_mmaxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_mmaxm_ec - - ! ! MIN: Minimum Value ! - subroutine psb_mmins(ictxt,dat,root) + subroutine psb_mmins(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -283,34 +225,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_min,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_min,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_min,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_mmins - subroutine psb_mminv(ictxt,dat,root) + subroutine psb_mminv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -319,42 +262,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_mminv - subroutine psb_mminm(ictxt,dat,root) + subroutine psb_mminm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -363,98 +307,49 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_mminm - subroutine psb_mmins_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_mmins_ec - - subroutine psb_mminv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_mminv_ec - - subroutine psb_mminm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_mminm_ec - - - ! ! SUM ! - subroutine psb_msums(ictxt,dat,root) + subroutine psb_msums(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -462,34 +357,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_msums - subroutine psb_msumv(ictxt,dat,root) + subroutine psb_msumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -498,42 +393,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_msumv - subroutine psb_msumm(ictxt,dat,root) + subroutine psb_msumm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -542,95 +437,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_msumm - subroutine psb_msums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_msums_ec - - subroutine psb_msumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_msumv_ec - - subroutine psb_msumm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_msumm_ec - - ! ! AMX: Maximum Absolute Value ! - subroutine psb_mamxs(ictxt,dat,root) + subroutine psb_mamxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -638,34 +485,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamx_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamx_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_mamxs - subroutine psb_mamxv(ictxt,dat,root) + subroutine psb_mamxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -674,42 +521,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) end if endif #endif end subroutine psb_mamxv - subroutine psb_mamxm(ictxt,dat,root) + subroutine psb_mamxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -718,96 +565,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,icomm,info) end if endif #endif end subroutine psb_mamxm - - subroutine psb_mamxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_mamxs_ec - - subroutine psb_mamxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_mamxv_ec - - subroutine psb_mamxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_mamxm_ec - - ! ! AMN: Minimum Absolute Value ! - subroutine psb_mamns(ictxt,dat,root) + subroutine psb_mamns(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -815,34 +613,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamn_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamn_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_mamns - subroutine psb_mamnv(ictxt,dat,root) + subroutine psb_mamnv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -851,42 +649,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) end if endif #endif end subroutine psb_mamnv - subroutine psb_mamnm(ictxt,dat,root) + subroutine psb_mamnm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -895,96 +693,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ integer(psb_mpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,icomm,info) end if endif #endif end subroutine psb_mamnm - - subroutine psb_mamns_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_mamns_ec - - subroutine psb_mamnv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_mamnv_ec - - subroutine psb_mamnm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_mamnm_ec - - ! ! BCAST Broadcast ! - subroutine psb_mbcasts(ictxt,dat,root) + subroutine psb_mbcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -992,29 +741,29 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - call mpi_bcast(dat,1,psb_mpi_mpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,psb_mpi_mpk_,root_,icomm,info) #endif end subroutine psb_mbcasts - subroutine psb_mbcastv(ictxt,dat,root) + subroutine psb_mbcastv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1023,28 +772,27 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_mpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_mpk_,root_,icomm,info) #endif end subroutine psb_mbcastv - subroutine psb_mbcastm(ictxt,dat,root) + subroutine psb_mbcastm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1053,85 +801,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_mpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_mpk_,root_,icomm,info) #endif end subroutine psb_mbcastm - - subroutine psb_mbcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_mbcasts_ec - - subroutine psb_mbcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_mbcastv_ec - - subroutine psb_mbcastm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_mbcastm_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SCAN ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_mscan_sums(ictxt,dat) + subroutine psb_mscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1139,23 +837,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_) :: dat_ integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo, icomm - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_scan(dat,dat_,1,psb_mpi_mpk_,mpi_sum,icomm,minfo) dat = dat_ #endif end subroutine psb_mscan_sums - subroutine psb_mexscan_sums(ictxt,dat) + subroutine psb_mexscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1163,7 +860,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat integer(psb_mpk_) :: dat_ integer(psb_ipk_) :: iam, np, info @@ -1171,8 +868,8 @@ contains #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_exscan(dat,dat_,1,psb_mpi_mpk_,mpi_sum,icomm,minfo) dat = dat_ #else @@ -1180,7 +877,7 @@ contains #endif end subroutine psb_mexscan_sums - subroutine psb_mscan_sumv(ictxt,dat,root) + subroutine psb_mscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1189,7 +886,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1198,8 +895,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1207,7 +904,7 @@ contains #endif end subroutine psb_mscan_sumv - subroutine psb_mexscan_sumv(ictxt,dat,root) + subroutine psb_mexscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1216,7 +913,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1225,8 +922,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1237,18 +934,17 @@ contains end subroutine psb_mexscan_sumv subroutine psb_m_simple_a2av(valsnd,sdsz,bsdindx,& - & valrcv,rvsz,brvindx,ictxt,info) + & valrcv,rvsz,brvindx,ctxt,info) use psi_m_p2p_mod implicit none integer(psb_mpk_), intent(in) :: valsnd(:) integer(psb_mpk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then idx = bsdindx(ip+1) - call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + call psb_snd(ctxt,valsnd(idx+1:idx+sz),ip) end if end do @@ -1267,14 +963,14 @@ contains sz = rvsz(ip+1) if (sz > 0) then idx = brvindx(ip+1) - call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + call psb_rcv(ctxt,valrcv(idx+1:idx+sz),ip) end if end do end subroutine psb_m_simple_a2av subroutine psb_m_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1287,7 +983,7 @@ contains integer(psb_mpk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1295,9 +991,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_int4_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1329,7 +1025,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_int4_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& @@ -1357,7 +1053,7 @@ contains end subroutine psb_m_m_simple_triad_a2av subroutine psb_m_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1370,7 +1066,7 @@ contains integer(psb_mpk_), intent(out) :: valrcv(:) integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1378,9 +1074,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_int4_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1412,7 +1108,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_int4_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& diff --git a/base/modules/penv/psi_m_p2p_mod.F90 b/base/modules/penv/psi_m_p2p_mod.F90 index f2600dc6..9f6c7bc6 100644 --- a/base/modules/penv/psi_m_p2p_mod.F90 +++ b/base/modules/penv/psi_m_p2p_mod.F90 @@ -32,22 +32,18 @@ module psi_m_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_snd - module procedure psb_msnds, psb_msndv, psb_msndm, & - & psb_msnds_ec, psb_msndv_ec, psb_msndm_ec + module procedure psb_msnds, psb_msndv, psb_msndm end interface interface psb_rcv - module procedure psb_mrcvs, psb_mrcvv, psb_mrcvm, & - & psb_mrcvs_ec, psb_mrcvv_ec, psb_mrcvm_ec + module procedure psb_mrcvs, psb_mrcvv, psb_mrcvm end interface contains - subroutine psb_msnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_msnds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -55,7 +51,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst integer(psb_mpk_), allocatable :: dat_(:) @@ -65,12 +61,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int4_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_msnds - subroutine psb_msndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_msndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -79,23 +74,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst integer(psb_mpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int4_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_msndv - subroutine psb_msndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_msndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -104,13 +98,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m integer(psb_mpk_), allocatable :: dat_(:) integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else @@ -128,12 +122,11 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_int4_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_msndm - subroutine psb_mrcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_mrcvs(ctxt,dat,src) #ifdef MPI_MOD use mpi #endif @@ -141,21 +134,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,psb_mpi_mpk_,src,psb_int4_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_mrcvs - subroutine psb_mrcvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_mrcvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -164,22 +157,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src integer(psb_mpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_mrcvv - subroutine psb_mrcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_mrcvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -188,14 +181,14 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m integer(psb_mpk_), allocatable :: dat_(:) integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_mpk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else @@ -205,11 +198,13 @@ contains n_ = size(dat,2) call mpi_type_vector(n_,m_,ld,psb_mpi_mpk_,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + icomm = psb_get_mpi_comm(ctxt) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_int4_tag,ictxt,status,info) + & psb_int4_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else - call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -218,90 +213,4 @@ contains #endif end subroutine psb_mrcvm - - subroutine psb_msnds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_msnds_ec - - subroutine psb_msndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_msndv_ec - - subroutine psb_msndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_msndm_ec - - subroutine psb_mrcvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_mrcvs_ec - - subroutine psb_mrcvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_mrcvv_ec - - subroutine psb_mrcvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_), intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_mrcvm_ec - - end module psi_m_p2p_mod diff --git a/base/modules/penv/psi_p2p_mod.F90 b/base/modules/penv/psi_p2p_mod.F90 index 39234474..f7262378 100644 --- a/base/modules/penv/psi_p2p_mod.F90 +++ b/base/modules/penv/psi_p2p_mod.F90 @@ -32,7 +32,6 @@ module psi_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod use psi_m_p2p_mod use psi_e_p2p_mod @@ -49,13 +48,11 @@ module psi_p2p_mod ! interface psb_snd module procedure psb_lsnds, psb_lsndv, psb_lsndm,& - & psb_hsnds, psb_lsnds_ec, psb_lsndv_ec, & - & psb_lsndm_ec, psb_hsnds_ec + & psb_hsnds end interface interface psb_rcv module procedure psb_lrcvs, psb_lrcvv, psb_lrcvm,& - & psb_hrcvs, psb_lrcvs_ec, psb_lrcvv_ec, & - & psb_lrcvm_ec, psb_hrcvs_ec + & psb_hrcvs end interface @@ -68,8 +65,7 @@ contains ! ! !!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_lsnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_lsnds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -77,7 +73,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(in) :: dat integer(psb_mpk_), intent(in) :: dst logical, allocatable :: dat_(:) @@ -87,12 +83,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_logical_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_lsnds - subroutine psb_lsndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_lsndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -101,7 +96,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst logical, allocatable :: dat_(:) @@ -111,13 +106,12 @@ contains #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_logical_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_lsndv - subroutine psb_lsndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_lsndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -126,7 +120,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m @@ -150,12 +144,12 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_logical_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_lsndm - subroutine psb_hsnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_hsnds(ctxt,dat,dst) + #ifdef MPI_MOD use mpi #endif @@ -163,7 +157,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt character(len=*), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst character(len=1), allocatable :: dat_(:) @@ -176,75 +170,18 @@ contains do i=1, l dat_(i) = dat(i:i) end do - call psi_snd(ictxt,psb_char_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_char_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_hsnds - subroutine psb_lsnds_ec(ictxt,dat,dst) - integer(psb_epk_), intent(in) :: ictxt - logical, intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_lsnds_ec - - subroutine psb_lsndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - logical, intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_lsndv_ec - - subroutine psb_lsndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - logical, intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_lsndm_ec - - - subroutine psb_hsnds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - character(len=*), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_hsnds_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!! ! ! Point-to-point RCV ! ! !!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_lrcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_lrcvs(ctxt,dat,src) + #ifdef MPI_MOD use mpi #endif @@ -252,21 +189,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,mpi_logical,src,psb_logical_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,mpi_logical,src,psb_logical_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_lrcvs - subroutine psb_lrcvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_lrcvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -275,21 +212,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src integer(psb_mpk_) :: info - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),mpi_logical,src,psb_logical_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),mpi_logical,src,psb_logical_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_lrcvv - subroutine psb_lrcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_lrcvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -298,16 +235,17 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_ipk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else + icomm = psb_get_mpi_comm(ctxt) if (present(m)) then m_ = m ld = size(dat,1) @@ -315,11 +253,11 @@ contains call mpi_type_vector(n_,m_,ld,mpi_logical,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_logical_tag,ictxt,status,info) + & psb_logical_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else call mpi_recv(dat,size(dat),mpi_logical,src,& - & psb_logical_tag,ictxt,status,info) + & psb_logical_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -329,8 +267,8 @@ contains end subroutine psb_lrcvm - subroutine psb_hrcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_hrcvs(ctxt,dat,src) + #ifdef MPI_MOD use mpi #endif @@ -338,18 +276,19 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt character(len=*), intent(out) :: dat integer(psb_mpk_), intent(in) :: src character(len=1), allocatable :: dat_(:) integer(psb_mpk_) :: info, l, i - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! do nothing #else l = len(dat) + icomm = psb_get_mpi_comm(ctxt) allocate(dat_(l), stat=info) - call mpi_recv(dat_,l,mpi_character,src,psb_char_tag,ictxt,status,info) + call mpi_recv(dat_,l,mpi_character,src,psb_char_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) do i=1, l dat(i:i) = dat_(i) @@ -358,61 +297,4 @@ contains #endif end subroutine psb_hrcvs - - subroutine psb_lrcvs_ec(ictxt,dat,src) - integer(psb_epk_), intent(in) :: ictxt - logical, intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_lrcvs_ec - - subroutine psb_lrcvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - logical, intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_lrcvv_ec - - subroutine psb_lrcvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - logical, intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_lrcvm_ec - - - subroutine psb_hrcvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - character(len=*), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_hrcvs_ec - end module psi_p2p_mod diff --git a/base/modules/penv/psi_penv_mod.F90 b/base/modules/penv/psi_penv_mod.F90 index 4bc18070..55dde0bb 100644 --- a/base/modules/penv/psi_penv_mod.F90 +++ b/base/modules/penv/psi_penv_mod.F90 @@ -29,9 +29,100 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +#if defined(SERIAL_MPI) +! Provide a fake mpi module just to keep the compiler(s) happy. +module mpi + use psb_const_mod + integer(psb_mpk_), parameter :: mpi_success = 0 + integer(psb_mpk_), parameter :: mpi_request_null = 0 + integer(psb_mpk_), parameter :: mpi_status_size = 1 + integer(psb_mpk_), parameter :: mpi_integer = 1 + integer(psb_mpk_), parameter :: mpi_integer8 = 2 + integer(psb_mpk_), parameter :: mpi_real = 3 + integer(psb_mpk_), parameter :: mpi_double_precision = 4 + integer(psb_mpk_), parameter :: mpi_complex = 5 + integer(psb_mpk_), parameter :: mpi_double_complex = 6 + integer(psb_mpk_), parameter :: mpi_character = 7 + integer(psb_mpk_), parameter :: mpi_logical = 8 + integer(psb_mpk_), parameter :: mpi_integer2 = 9 + integer(psb_mpk_), parameter :: mpi_comm_null = -1 + integer(psb_mpk_), parameter :: mpi_comm_world = 1 + + real(psb_dpk_), external :: mpi_wtime +end module mpi +#endif + + module psi_penv_mod use psb_const_mod - use psi_comm_buffers_mod, only : psb_buffer_queue + + integer(psb_mpk_), parameter:: psb_int_tag = 543987 + integer(psb_mpk_), parameter:: psb_real_tag = psb_int_tag + 1 + integer(psb_mpk_), parameter:: psb_double_tag = psb_real_tag + 1 + integer(psb_mpk_), parameter:: psb_complex_tag = psb_double_tag + 1 + integer(psb_mpk_), parameter:: psb_dcomplex_tag = psb_complex_tag + 1 + integer(psb_mpk_), parameter:: psb_logical_tag = psb_dcomplex_tag + 1 + integer(psb_mpk_), parameter:: psb_char_tag = psb_logical_tag + 1 + integer(psb_mpk_), parameter:: psb_int8_tag = psb_char_tag + 1 + integer(psb_mpk_), parameter:: psb_int2_tag = psb_int8_tag + 1 + integer(psb_mpk_), parameter:: psb_int4_tag = psb_int2_tag + 1 + integer(psb_mpk_), parameter:: psb_long_tag = psb_int4_tag + 1 + + integer(psb_mpk_), parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_double_swap_tag = psb_double_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_complex_swap_tag = psb_complex_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_dcomplex_swap_tag = psb_dcomplex_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_logical_swap_tag = psb_logical_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_char_swap_tag = psb_char_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_int2_swap_tag = psb_int2_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_int4_swap_tag = psb_int4_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_long_swap_tag = psb_long_tag + psb_int_tag + + + + integer(psb_mpk_), private, parameter:: psb_int_type = 987543 + integer(psb_mpk_), private, parameter:: psb_real_type = psb_int_type + 1 + integer(psb_mpk_), private, parameter:: psb_double_type = psb_real_type + 1 + integer(psb_mpk_), private, parameter:: psb_complex_type = psb_double_type + 1 + integer(psb_mpk_), private, parameter:: psb_dcomplex_type = psb_complex_type + 1 + integer(psb_mpk_), private, parameter:: psb_logical_type = psb_dcomplex_type + 1 + integer(psb_mpk_), private, parameter:: psb_char_type = psb_logical_type + 1 + integer(psb_mpk_), private, parameter:: psb_int8_type = psb_char_type + 1 + integer(psb_mpk_), private, parameter:: psb_int2_type = psb_int8_type + 1 + integer(psb_mpk_), private, parameter:: psb_int4_type = psb_int2_type + 1 + integer(psb_mpk_), private, parameter:: psb_long_type = psb_int4_type + 1 + + type psb_buffer_node + integer(psb_mpk_) :: request + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: buffer_type + integer(psb_epk_), allocatable :: int8buf(:) + integer(psb_i2pk_), allocatable :: int2buf(:) + integer(psb_mpk_), allocatable :: int4buf(:) + real(psb_spk_), allocatable :: realbuf(:) + real(psb_dpk_), allocatable :: doublebuf(:) + complex(psb_spk_), allocatable :: complexbuf(:) + complex(psb_dpk_), allocatable :: dcomplbuf(:) + logical, allocatable :: logbuf(:) + character(len=1), allocatable :: charbuf(:) + type(psb_buffer_node), pointer :: prev=>null(), next=>null() + end type psb_buffer_node + + type psb_buffer_queue + type(psb_buffer_node), pointer :: head=>null(), tail=>null() + end type psb_buffer_queue + + interface psi_snd + module procedure& + & psi_msnd, psi_esnd,& + & psi_ssnd, psi_dsnd,& + & psi_csnd, psi_zsnd,& + & psi_logsnd, psi_hsnd,& + & psi_i2snd + end interface + interface psb_init module procedure psb_init_mpik @@ -48,41 +139,26 @@ module psi_penv_mod interface psb_info module procedure psb_info_mpik end interface - - interface psb_barrier - module procedure psb_barrier_mpik - end interface - - interface psb_init - module procedure psb_init_epk - end interface - - interface psb_exit - module procedure psb_exit_epk - end interface - - interface psb_abort - module procedure psb_abort_epk - end interface - +#if defined(IPK4) && defined(LPK8) interface psb_info module procedure psb_info_epk end interface - +#endif + interface psb_barrier - module procedure psb_barrier_epk + module procedure psb_barrier_mpik end interface - + interface psb_wtime module procedure psb_wtime end interface psb_wtime interface psb_get_mpi_comm - module procedure psb_m_get_mpi_comm, psb_e_get_mpi_comm + module procedure psb_m_get_mpi_comm !, psb_e_get_mpi_comm end interface psb_get_mpi_comm interface psb_get_mpi_rank - module procedure psb_m_get_mpi_rank, psb_e_get_mpi_rank + module procedure psb_m_get_mpi_rank!, psb_e_get_mpi_rank end interface psb_get_mpi_rank #if defined(SERIAL_MPI) @@ -115,6 +191,502 @@ module psi_penv_mod contains + subroutine psb_init_queue(mesg_queue,info) + implicit none + type(psb_buffer_queue), intent(inout) :: mesg_queue + integer(psb_ipk_), intent(out) :: info + + info = 0 + if ((.not.associated(mesg_queue%head)).and.& + & (.not.associated(mesg_queue%tail))) then + ! Nothing to do + return + end if + + if ((.not.associated(mesg_queue%head)).or.& + & (.not.associated(mesg_queue%tail))) then + ! If we are here one is associated, the other is not. + ! This is impossible. + info = -1 + write(psb_err_unit,*) 'Wrong status on init ' + return + end if + + end subroutine psb_init_queue + + subroutine psb_wait_buffer(node, info) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_buffer_node), intent(inout) :: node + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: status(mpi_status_size),minfo + minfo = mpi_success + call mpi_wait(node%request,status,minfo) + info=minfo + end subroutine psb_wait_buffer + + subroutine psb_test_buffer(node, flag, info) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_buffer_node), intent(inout) :: node + logical, intent(out) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: status(mpi_status_size), minfo + minfo = mpi_success +#if defined(SERIAL_MPI) + flag = .true. +#else + call mpi_test(node%request,flag,status,minfo) +#endif + info=minfo + end subroutine psb_test_buffer + + + subroutine psb_close_context(mesg_queue,icontxt) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_ctxt_type), intent(in) :: icontxt + integer(psb_ipk_) :: info + type(psb_buffer_node), pointer :: node, nextnode + + node => mesg_queue%head + do + if (.not.associated(node)) exit + nextnode => node%next + if (psb_cmp_ctxt(node%icontxt,icontxt)) then + call psb_wait_buffer(node,info) + call psb_delete_node(mesg_queue,node) + end if + node => nextnode + end do + end subroutine psb_close_context + + subroutine psb_close_all_context(mesg_queue) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_buffer_node), pointer :: node, nextnode + integer(psb_ipk_) :: info + + node => mesg_queue%head + do + if (.not.associated(node)) exit + nextnode => node%next + call psb_wait_buffer(node,info) + call psb_delete_node(mesg_queue,node) + node => nextnode + end do + end subroutine psb_close_all_context + + + subroutine psb_delete_node(mesg_queue,node) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_buffer_node), pointer :: node + type(psb_buffer_node), pointer :: prevnode + + if (.not.associated(node)) then + return + end if + prevnode => node%prev + if (associated(mesg_queue%head,node)) mesg_queue%head => node%next + if (associated(mesg_queue%tail,node)) mesg_queue%tail => prevnode + if (associated(prevnode)) prevnode%next => node%next + if (associated(node%next)) node%next%prev => prevnode + deallocate(node) + + end subroutine psb_delete_node + + subroutine psb_insert_node(mesg_queue,node) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_buffer_node), pointer :: node + + node%next => null() + node%prev => null() + if ((.not.associated(mesg_queue%head)).and.& + & (.not.associated(mesg_queue%tail))) then + mesg_Queue%head => node + mesg_queue%tail => node + return + end if + mesg_queue%tail%next => node + node%prev => mesg_queue%tail + mesg_queue%tail => node + + end subroutine psb_insert_node + + subroutine psb_test_nodes(mesg_queue) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node, nextnode + integer(psb_ipk_) :: info + logical :: flag + + node => mesg_queue%head + do + if (.not.associated(node)) exit + nextnode => node%next + call psb_test_buffer(node,flag,info) + if (flag) then + call psb_delete_node(mesg_queue,node) + end if + node => nextnode + end do + end subroutine psb_test_nodes + + ! !!!!!!!!!!!!!!!!! + ! + ! Inner send. Basic idea: + ! the input buffer is MOVE_ALLOCed + ! to a node in the mesg queue, then it is sent. + ! Thus the calling process should guarantee that + ! the buffer is dispensable, i.e. the user data + ! has already been copied. + ! + ! !!!!!!!!!!!!!!!!! + subroutine psi_msnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + integer(psb_mpk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_int_type + call move_alloc(buffer,node%int4buf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%int4buf,size(node%int4buf),psb_mpi_mpk_,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_msnd + + + subroutine psi_esnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + integer(psb_epk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_int8_type + call move_alloc(buffer,node%int8buf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%int8buf,size(node%int8buf),psb_mpi_epk_,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_esnd + + subroutine psi_i2snd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + integer(psb_i2pk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_int2_type + call move_alloc(buffer,node%int2buf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%int2buf,size(node%int2buf),psb_mpi_i2pk_,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_i2snd + + subroutine psi_ssnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + real(psb_spk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_real_type + call move_alloc(buffer,node%realbuf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%realbuf,size(node%realbuf),psb_mpi_r_spk_,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_ssnd + + subroutine psi_dsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + real(psb_dpk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_double_type + call move_alloc(buffer,node%doublebuf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%doublebuf,size(node%doublebuf),psb_mpi_r_dpk_,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_dsnd + + subroutine psi_csnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + complex(psb_spk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_complex_type + call move_alloc(buffer,node%complexbuf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%complexbuf,size(node%complexbuf),psb_mpi_c_spk_,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_csnd + + subroutine psi_zsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + complex(psb_dpk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_dcomplex_type + call move_alloc(buffer,node%dcomplbuf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%dcomplbuf,size(node%dcomplbuf),psb_mpi_c_dpk_,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_zsnd + + + subroutine psi_logsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + logical, allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_logical_type + call move_alloc(buffer,node%logbuf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%logbuf,size(node%logbuf),mpi_logical,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_logsnd + + + subroutine psi_hsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type) :: icontxt + integer(psb_mpk_) :: tag, dest + character(len=1), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer(psb_ipk_) :: info + integer(psb_mpk_) :: minfo, icomm + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + icomm = psb_get_mpi_comm(icontxt) + node%buffer_type = psb_char_type + call move_alloc(buffer,node%charbuf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%charbuf,size(node%charbuf),mpi_character,& + & dest,tag,icomm,node%request,minfo) + info = minfo + call psb_insert_node(mesg_queue,node) + call psb_test_nodes(mesg_queue) + + end subroutine psi_hsnd + + ! !!!!!!!!!!!!!!!!!!!!!! ! ! Environment handling @@ -207,87 +779,84 @@ contains end subroutine psi_register_mpi_extras - subroutine psb_init_epk(ictxt,np,basectxt,ids) - integer(psb_epk_), intent(out) :: ictxt - integer(psb_epk_), intent(in), optional :: np, basectxt, ids(:) - - integer(psb_mpk_) :: iictxt - integer(psb_mpk_) :: inp, ibasectxt - integer(psb_mpk_), allocatable :: ids_(:) - - if (present(ids)) then - allocate(ids_(size(ids))) - ids_ = ids - else - allocate(ids_(0)) - end if - if (present(np).and.present(basectxt)) then - inp = np - ibasectxt = basectxt - call psb_init(iictxt,np=inp,basectxt=ibasectxt,ids=ids_) - else if (present(np)) then - inp = np - call psb_init(iictxt,np=inp,ids=ids_) - else if (present(basectxt)) then - ibasectxt = basectxt - call psb_init(iictxt,basectxt=ibasectxt,ids=ids_) - else - call psb_init(iictxt,ids=ids_) - end if - ictxt = iictxt - end subroutine psb_init_epk - - subroutine psb_exit_epk(ictxt,close) - integer(psb_epk_), intent(inout) :: ictxt - logical, intent(in), optional :: close - integer(psb_mpk_) :: iictxt - - iictxt = ictxt - call psb_exit(iictxt, close) - end subroutine psb_exit_epk - - subroutine psb_barrier_epk(ictxt) - integer(psb_epk_), intent(in) :: ictxt - integer(psb_mpk_) :: iictxt - - iictxt = ictxt - call psb_barrier(iictxt) - end subroutine psb_barrier_epk - - subroutine psb_abort_epk(ictxt,errc) - integer(psb_epk_), intent(in) :: ictxt - integer(psb_epk_), intent(in), optional :: errc - integer(psb_mpk_) :: iictxt, ierrc - - iictxt = ictxt - if (present(errc)) then - ierrc = errc - call psb_abort(iictxt,ierrc) - else - call psb_abort(iictxt) - end if - end subroutine psb_abort_epk - - subroutine psb_info_epk(ictxt,iam,np) - - integer(psb_epk_), intent(in) :: ictxt +!!$ subroutine psb_init_epk(ctxt,np,basectxt,ids) +!!$ type(psb_ctxt_type), intent(out) :: ctxt +!!$ integer(psb_epk_), intent(in), optional :: np, basectxt, ids(:) +!!$ +!!$ integer(psb_mpk_) :: ictxt +!!$ integer(psb_mpk_) :: inp, ibasectxt +!!$ integer(psb_mpk_), allocatable :: ids_(:) +!!$ +!!$ if (present(ids)) then +!!$ allocate(ids_(size(ids))) +!!$ ids_ = ids +!!$ else +!!$ allocate(ids_(0)) +!!$ end if +!!$ if (present(np).and.present(basectxt)) then +!!$ inp = np +!!$ ibasectxt = basectxt +!!$ call psb_init(ctxt,np=inp,basectxt=ibasectxt,ids=ids_) +!!$ else if (present(np)) then +!!$ inp = np +!!$ call psb_init(ctxt,np=inp,ids=ids_) +!!$ else if (present(basectxt)) then +!!$ ibasectxt = basectxt +!!$ call psb_init(ctxt,basectxt=ibasectxt,ids=ids_) +!!$ else +!!$ call psb_init(ctxt,ids=ids_) +!!$ end if +!!$ end subroutine psb_init_epk + +!!$ subroutine psb_exit_epk(ctxt,close) +!!$ integer(psb_epk_), intent(inout) :: ctxt +!!$ logical, intent(in), optional :: close +!!$ integer(psb_mpk_) :: ictxt +!!$ +!!$ ictxt = ctxt +!!$ call psb_exit(ictxt, close) +!!$ end subroutine psb_exit_epk +!!$ +!!$ subroutine psb_barrier_epk(ctxt) +!!$ integer(psb_epk_), intent(in) :: ctxt +!!$ integer(psb_mpk_) :: ictxt +!!$ +!!$ ictxt = ctxt +!!$ call psb_barrier(ictxt) +!!$ end subroutine psb_barrier_epk +!!$ +!!$ subroutine psb_abort_epk(ctxt,errc) +!!$ integer(psb_epk_), intent(in) :: ctxt +!!$ integer(psb_epk_), intent(in), optional :: errc +!!$ integer(psb_mpk_) :: ictxt, ierrc +!!$ +!!$ ictxt = ctxt +!!$ if (present(errc)) then +!!$ ierrc = errc +!!$ call psb_abort(ictxt,ierrc) +!!$ else +!!$ call psb_abort(ictxt) +!!$ end if +!!$ end subroutine psb_abort_epk +!!$ +#if defined(IPK4) && defined(LPK8) + subroutine psb_info_epk(ctxt,iam,np) + + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_epk_), intent(out) :: iam, np ! ! Simple caching scheme, keep track ! of the last CTXT encountered. ! - integer(psb_mpk_), save :: lctxt=-1, lam, lnp - if (ictxt /= lctxt) then - lctxt = ictxt - call psb_info(lctxt,lam,lnp) - end if + integer(psb_mpk_), save :: lam, lnp + call psb_info(ctxt,lam,lnp) iam = lam np = lnp end subroutine psb_info_epk +#endif - subroutine psb_init_mpik(ictxt,np,basectxt,ids) - use psi_comm_buffers_mod + subroutine psb_init_mpik(ctxt,np,basectxt,ids) use psb_const_mod use psb_error_mod use psb_mat_mod @@ -300,10 +869,11 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(out) :: ictxt - integer(psb_mpk_), intent(in), optional :: np, basectxt, ids(:) + type(psb_ctxt_type), intent(out) :: ctxt + type(psb_ctxt_type), intent(in), optional :: basectxt + integer(psb_mpk_), intent(in), optional :: np, ids(:) - integer(psb_mpk_) :: i, isnullcomm + integer(psb_mpk_) :: i, isnullcomm, icomm integer(psb_mpk_), allocatable :: iids(:) logical :: initialized integer(psb_mpk_) :: np_, npavail, iam, info, basecomm, basegroup, newgroup @@ -313,7 +883,7 @@ contains call psb_set_debug_unit(psb_err_unit) #if defined(SERIAL_MPI) - ictxt = nctxt + ctxt = nctxt nctxt = nctxt + 1 call psi_register_mpi_extras(info) @@ -329,8 +899,12 @@ contains end if end if - if (present(basectxt)) then - basecomm = basectxt + if (present(basectxt)) then + if (allocated(basectxt%ctxt)) then + basecomm = basectxt%ctxt + else + basecomm = mpi_comm_world + end if else basecomm = mpi_comm_world end if @@ -340,7 +914,7 @@ contains iinfo=psb_err_initerror_neugh_procs_ call psb_errpush(iinfo,name) call psb_error() - ictxt = mpi_comm_null + !ctxt = mpi_comm_null return endif call mpi_comm_size(basecomm,np_,info) @@ -348,32 +922,32 @@ contains iinfo=psb_err_initerror_neugh_procs_ call psb_errpush(iinfo,name) call psb_error() - ictxt = mpi_comm_null + !ctxt = mpi_comm_null return endif call mpi_comm_group(basecomm,basegroup,info) if (present(ids)) then if (size(ids)np_)) then write(psb_err_unit,*) 'Error in init: invalid rank in input' - ictxt = mpi_comm_null + !ctxt%ctxt = mpi_comm_null return end if end do call mpi_group_incl(basegroup,np,ids,newgroup,info) if (info /= mpi_success) then - ictxt = mpi_comm_null + !ctxt%ctxt = mpi_comm_null return endif else allocate(iids(np),stat=info) if (info /= 0) then - ictxt = mpi_comm_null + !ctxt%ctxt = mpi_comm_null return endif do i=1, np @@ -381,23 +955,28 @@ contains end do call mpi_group_incl(basegroup,np,iids,newgroup,info) if (info /= mpi_success) then - ictxt = mpi_comm_null + !ctxt = mpi_comm_null return endif deallocate(iids) end if - call mpi_comm_create(basecomm,newgroup,ictxt,info) - + + call mpi_comm_create(basecomm,newgroup,icomm,info) + else if (basecomm /= mpi_comm_null) then - call mpi_comm_dup(basecomm,ictxt,info) + call mpi_comm_dup(basecomm,icomm,info) else - ictxt = mpi_comm_null + ! ctxt = mpi_comm_null end if endif + if (info == 0) then + ctxt%ctxt = icomm ! allocate on assignment + end if call psi_register_mpi_extras(info) call psi_get_sizes() - if (ictxt == mpi_comm_null) return + !if (ctxt == mpi_comm_null) return + if (.not.allocated(ctxt%ctxt)) return #endif call psb_init_vect_defaults() call psb_init_mat_defaults() @@ -410,14 +989,13 @@ contains ! !$ ! or shall we tolerate this ? ! !$ info=psb_err_internal_error_ ! !$ call psb_errpush(info,name) - ! !$ call psb_error(ictxt) + ! !$ call psb_error(ctxt) ! !$ endif ! !$ endif end subroutine psb_init_mpik - subroutine psb_exit_mpik(ictxt,close) - use psi_comm_buffers_mod + subroutine psb_exit_mpik(ctxt,close) use psb_mat_mod use psb_vect_mod ! !$ use psb_rsb_mod @@ -428,7 +1006,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(inout) :: ictxt + type(psb_ctxt_type), intent(inout) :: ctxt logical, intent(in), optional :: close logical :: close_ integer(psb_mpk_) :: info @@ -447,21 +1025,22 @@ contains ! !$ else ! !$ info=psb_err_internal_error_ ! rsb failed to exit, and we issue an internal error. or shall we tolerate this ? ! !$ call psb_errpush(info,name) -! !$ call psb_error(ictxt) +! !$ call psb_error(ctxt) ! !$ endif ! !$ endif #if defined(SERIAL_MPI) ! Under serial mode, CLOSE has no effect, but reclaim - ! the used ICTXT number. + ! the used ctxt number. nctxt = max(0, nctxt - 1) #else if (close_) then call psb_close_all_context(psb_mesg_queue) else - call psb_close_context(psb_mesg_queue,ictxt) + call psb_close_context(psb_mesg_queue,ctxt) end if - if ((ictxt /= mpi_comm_null).and.(ictxt /= mpi_comm_world)) then - call mpi_comm_Free(ictxt,info) + !if ((ctxt /= mpi_comm_null).and.(ctxt /= mpi_comm_world)) then + if (allocated(ctxt%ctxt)) then + if (ctxt%ctxt /= mpi_comm_world)call mpi_comm_Free(ctxt%ctxt,info) end if if (close_) call mpi_finalize(info) @@ -473,7 +1052,7 @@ contains end subroutine psb_exit_mpik - subroutine psb_barrier_mpik(ictxt) + subroutine psb_barrier_mpik(ctxt) #ifdef MPI_MOD use mpi #endif @@ -481,12 +1060,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_) :: info #if !defined(SERIAL_MPI) - if (ictxt /= mpi_comm_null) then - call mpi_barrier(ictxt, info) + if (allocated(ctxt%ctxt)) then + if (ctxt%ctxt /= mpi_comm_null) call mpi_barrier(ctxt%ctxt, info) end if #endif @@ -507,10 +1086,9 @@ contains psb_wtime = mpi_wtime() end function psb_wtime - subroutine psb_abort_mpik(ictxt,errc) - use psi_comm_buffers_mod + subroutine psb_abort_mpik(ctxt,errc) - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(in), optional :: errc integer(psb_mpk_) :: code, info @@ -524,14 +1102,13 @@ contains code = -1 endif - call mpi_abort(ictxt,code,info) + if (allocated(ctxt%ctxt)) call mpi_abort(ctxt%ctxt,code,info) #endif end subroutine psb_abort_mpik - subroutine psb_info_mpik(ictxt,iam,np) - use psi_comm_buffers_mod + subroutine psb_info_mpik(ctxt,iam,np) #ifdef MPI_MOD use mpi #endif @@ -540,7 +1117,7 @@ contains include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_mpk_), intent(out) :: iam, np integer(psb_mpk_) :: info ! @@ -555,64 +1132,53 @@ contains #else iam = -1 np = -1 - if (ictxt == lctxt) then - iam = lam - np = lnp - else - if (ictxt /= mpi_comm_null) then - call mpi_comm_size(ictxt,np,info) - if (info /= mpi_success) np = -1 - call mpi_comm_rank(ictxt,iam,info) - if (info /= mpi_success) iam = -1 + if (allocated(ctxt%ctxt)) then + if (ctxt%ctxt == lctxt) then + iam = lam + np = lnp + else + if (ctxt%ctxt /= mpi_comm_null) then + call mpi_comm_size(ctxt%ctxt,np,info) + if (info /= mpi_success) np = -1 + call mpi_comm_rank(ctxt%ctxt,iam,info) + if (info /= mpi_success) iam = -1 + end if + lctxt = ctxt%ctxt + lam = iam + lnp = np end if - lctxt = ictxt - lam = iam - lnp = np end if #endif - end subroutine psb_info_mpik - function psb_m_get_mpi_comm(ictxt) result(comm) - integer(psb_mpk_) :: ictxt, comm - - comm = ictxt - end function psb_m_get_mpi_comm - - function psb_e_get_mpi_comm(ictxt) result(comm) - integer(psb_epk_) :: ictxt + function psb_m_get_mpi_comm(ctxt) result(comm) + type(psb_ctxt_type) :: ctxt integer(psb_mpk_) :: comm + comm = mpi_comm_null + if (allocated(ctxt%ctxt)) comm = ctxt%ctxt + end function psb_m_get_mpi_comm - comm = ictxt - end function psb_e_get_mpi_comm - - function psb_m_get_mpi_rank(ictxt,id) result(rank) + function psb_m_get_mpi_rank(ctxt,id) result(rank) integer(psb_mpk_) :: rank - integer(psb_mpk_) :: ictxt,id + integer(psb_mpk_) :: id + type(psb_ctxt_type) :: ctxt rank = id end function psb_m_get_mpi_rank - - function psb_e_get_mpi_rank(ictxt,id) result(rank) - integer(psb_mpk_) :: rank - integer(psb_epk_) :: ictxt,id - - rank = id - end function psb_e_get_mpi_rank - - - subroutine psb_get_mpicomm(ictxt,comm) - integer(psb_mpk_) :: ictxt, comm - - comm = psb_get_mpi_comm(ictxt) + subroutine psb_get_mpicomm(ctxt,comm) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: comm + comm = mpi_comm_null + if (allocated(ctxt%ctxt)) comm = ctxt%ctxt end subroutine psb_get_mpicomm - subroutine psb_get_rank(rank,ictxt,id) - integer(psb_mpk_) :: rank,ictxt,id + subroutine psb_get_rank(rank,ctxt,id) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: rank,id - rank = psb_get_mpi_rank(ictxt,id) + rank = psb_get_mpi_rank(ctxt,id) end subroutine psb_get_rank @@ -789,4 +1355,5 @@ contains end do end subroutine psi_dnrm2_op + end module psi_penv_mod diff --git a/base/modules/penv/psi_s_collective_mod.F90 b/base/modules/penv/psi_s_collective_mod.F90 index e4fb9d06..82f96aac 100644 --- a/base/modules/penv/psi_s_collective_mod.F90 +++ b/base/modules/penv/psi_s_collective_mod.F90 @@ -31,42 +31,33 @@ ! module psi_s_collective_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_max - module procedure psb_smaxs, psb_smaxv, psb_smaxm, & - & psb_smaxs_ec, psb_smaxv_ec, psb_smaxm_ec + module procedure psb_smaxs, psb_smaxv, psb_smaxm end interface interface psb_min - module procedure psb_smins, psb_sminv, psb_sminm, & - & psb_smins_ec, psb_sminv_ec, psb_sminm_ec + module procedure psb_smins, psb_sminv, psb_sminm end interface psb_min interface psb_nrm2 - module procedure psb_s_nrm2s, psb_s_nrm2v, & - & psb_s_nrm2s_ec, psb_s_nrm2v_ec + module procedure psb_s_nrm2s, psb_s_nrm2v end interface psb_nrm2 interface psb_sum - module procedure psb_ssums, psb_ssumv, psb_ssumm, & - & psb_ssums_ec, psb_ssumv_ec, psb_ssumm_ec + module procedure psb_ssums, psb_ssumv, psb_ssumm end interface interface psb_amx - module procedure psb_samxs, psb_samxv, psb_samxm, & - & psb_samxs_ec, psb_samxv_ec, psb_samxm_ec + module procedure psb_samxs, psb_samxv, psb_samxm end interface interface psb_amn - module procedure psb_samns, psb_samnv, psb_samnm, & - & psb_samns_ec, psb_samnv_ec, psb_samnm_ec + module procedure psb_samns, psb_samnv, psb_samnm end interface - interface psb_bcast - module procedure psb_sbcasts, psb_sbcastv, psb_sbcastm, & - & psb_sbcasts_ec, psb_sbcastv_ec, psb_sbcastm_ec + module procedure psb_sbcasts, psb_sbcastv, psb_sbcastm end interface psb_bcast interface psb_scan_sum @@ -85,7 +76,6 @@ module psi_s_collective_mod module procedure psb_s_e_simple_triad_a2av, psb_s_m_simple_triad_a2av end interface psb_simple_triad_a2av - contains ! !!!!!!!!!!!!!!!!!!!!!! @@ -101,7 +91,7 @@ contains ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_smaxs(ictxt,dat,root) + subroutine psb_smaxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -109,34 +99,33 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info - integer(psb_ipk_) :: iinfo - + integer(psb_mpk_) :: iam, np, info, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_smaxs - subroutine psb_smaxv(ictxt,dat,root) + subroutine psb_smaxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -145,42 +134,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_smaxv - subroutine psb_smaxm(ictxt,dat,root) + subroutine psb_smaxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -189,97 +179,48 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,icomm,info) end if endif #endif end subroutine psb_smaxm - - subroutine psb_smaxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_smaxs_ec - - subroutine psb_smaxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_smaxv_ec - - subroutine psb_smaxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_smaxm_ec - - ! ! MIN: Minimum Value ! - subroutine psb_smins(ictxt,dat,root) + subroutine psb_smins(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -287,34 +228,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_smins - subroutine psb_sminv(ictxt,dat,root) + subroutine psb_sminv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -323,42 +265,43 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_sminv - subroutine psb_sminm(ictxt,dat,root) + subroutine psb_sminm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -367,98 +310,49 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,icomm,info) end if endif #endif end subroutine psb_sminm - subroutine psb_smins_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_smins_ec - - subroutine psb_sminv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_sminv_ec - - subroutine psb_sminm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_sminm_ec - - - ! !!!!!!!!!!!! ! ! Norm 2, only for reals ! ! !!!!!!!!!!!! - subroutine psb_s_nrm2s(ictxt,dat,root) + subroutine psb_s_nrm2s(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -466,34 +360,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_s_nrm2s - subroutine psb_s_nrm2v(ictxt,dat,root) + subroutine psb_s_nrm2v(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -502,82 +397,51 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,& - & mpi_snrm2_op,ictxt,info) + & mpi_snrm2_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,& - & mpi_snrm2_op,root_,ictxt,info) + & mpi_snrm2_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,& - & mpi_snrm2_op,root_,ictxt,info) + & mpi_snrm2_op,root_,icomm,info) end if endif #endif end subroutine psb_s_nrm2v - subroutine psb_s_nrm2s_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_s_nrm2s_ec - - subroutine psb_s_nrm2v_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_s_nrm2v_ec - ! ! SUM ! - subroutine psb_ssums(ictxt,dat,root) + subroutine psb_ssums(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -585,34 +449,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_ssums - subroutine psb_ssumv(ictxt,dat,root) + subroutine psb_ssumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -621,42 +485,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_ssumv - subroutine psb_ssumm(ictxt,dat,root) + subroutine psb_ssumm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -665,95 +529,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_ssumm - subroutine psb_ssums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_ssums_ec - - subroutine psb_ssumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_ssumv_ec - - subroutine psb_ssumm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_ssumm_ec - - ! ! AMX: Maximum Absolute Value ! - subroutine psb_samxs(ictxt,dat,root) + subroutine psb_samxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -761,34 +577,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_samxs - subroutine psb_samxv(ictxt,dat,root) + subroutine psb_samxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -797,42 +613,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) end if endif #endif end subroutine psb_samxv - subroutine psb_samxm(ictxt,dat,root) + subroutine psb_samxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -841,96 +657,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,icomm,info) end if endif #endif end subroutine psb_samxm - - subroutine psb_samxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_samxs_ec - - subroutine psb_samxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_samxv_ec - - subroutine psb_samxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_samxm_ec - - ! ! AMN: Minimum Absolute Value ! - subroutine psb_samns(ictxt,dat,root) + subroutine psb_samns(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -938,34 +705,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_samns - subroutine psb_samnv(ictxt,dat,root) + subroutine psb_samnv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -974,42 +741,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) end if endif #endif end subroutine psb_samnv - subroutine psb_samnm(ictxt,dat,root) + subroutine psb_samnm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1018,96 +785,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,icomm,info) end if endif #endif end subroutine psb_samnm - - subroutine psb_samns_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_samns_ec - - subroutine psb_samnv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_samnv_ec - - subroutine psb_samnm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_samnm_ec - - ! ! BCAST Broadcast ! - subroutine psb_sbcasts(ictxt,dat,root) + subroutine psb_sbcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -1115,29 +833,29 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - call mpi_bcast(dat,1,psb_mpi_r_spk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,psb_mpi_r_spk_,root_,icomm,info) #endif end subroutine psb_sbcasts - subroutine psb_sbcastv(ictxt,dat,root) + subroutine psb_sbcastv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1146,28 +864,27 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,icomm,info) #endif end subroutine psb_sbcastv - subroutine psb_sbcastm(ictxt,dat,root) + subroutine psb_sbcastm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1176,85 +893,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,icomm,info) #endif end subroutine psb_sbcastm - - subroutine psb_sbcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_sbcasts_ec - - subroutine psb_sbcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_sbcastv_ec - - subroutine psb_sbcastm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_sbcastm_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SCAN ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_sscan_sums(ictxt,dat) + subroutine psb_sscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1262,23 +929,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat real(psb_spk_) :: dat_ integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo, icomm - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_scan(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,icomm,minfo) dat = dat_ #endif end subroutine psb_sscan_sums - subroutine psb_sexscan_sums(ictxt,dat) + subroutine psb_sexscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -1286,7 +952,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat real(psb_spk_) :: dat_ integer(psb_ipk_) :: iam, np, info @@ -1294,8 +960,8 @@ contains #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_exscan(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,icomm,minfo) dat = dat_ #else @@ -1303,7 +969,7 @@ contains #endif end subroutine psb_sexscan_sums - subroutine psb_sscan_sumv(ictxt,dat,root) + subroutine psb_sscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1312,7 +978,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1321,8 +987,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1330,7 +996,7 @@ contains #endif end subroutine psb_sscan_sumv - subroutine psb_sexscan_sumv(ictxt,dat,root) + subroutine psb_sexscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -1339,7 +1005,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -1348,8 +1014,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -1360,18 +1026,17 @@ contains end subroutine psb_sexscan_sumv subroutine psb_s_simple_a2av(valsnd,sdsz,bsdindx,& - & valrcv,rvsz,brvindx,ictxt,info) + & valrcv,rvsz,brvindx,ctxt,info) use psi_s_p2p_mod implicit none real(psb_spk_), intent(in) :: valsnd(:) real(psb_spk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then idx = bsdindx(ip+1) - call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + call psb_snd(ctxt,valsnd(idx+1:idx+sz),ip) end if end do @@ -1390,14 +1055,14 @@ contains sz = rvsz(ip+1) if (sz > 0) then idx = brvindx(ip+1) - call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + call psb_rcv(ctxt,valrcv(idx+1:idx+sz),ip) end if end do end subroutine psb_s_simple_a2av subroutine psb_s_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1410,7 +1075,7 @@ contains real(psb_spk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1418,9 +1083,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_real_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1452,7 +1117,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_real_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& @@ -1480,7 +1145,7 @@ contains end subroutine psb_s_m_simple_triad_a2av subroutine psb_s_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1493,7 +1158,7 @@ contains real(psb_spk_), intent(out) :: valrcv(:) integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1501,9 +1166,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_real_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1535,7 +1200,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_real_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& diff --git a/base/modules/penv/psi_s_p2p_mod.F90 b/base/modules/penv/psi_s_p2p_mod.F90 index 91f4d739..9c7f9d66 100644 --- a/base/modules/penv/psi_s_p2p_mod.F90 +++ b/base/modules/penv/psi_s_p2p_mod.F90 @@ -32,22 +32,18 @@ module psi_s_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_snd - module procedure psb_ssnds, psb_ssndv, psb_ssndm, & - & psb_ssnds_ec, psb_ssndv_ec, psb_ssndm_ec + module procedure psb_ssnds, psb_ssndv, psb_ssndm end interface interface psb_rcv - module procedure psb_srcvs, psb_srcvv, psb_srcvm, & - & psb_srcvs_ec, psb_srcvv_ec, psb_srcvm_ec + module procedure psb_srcvs, psb_srcvv, psb_srcvm end interface contains - subroutine psb_ssnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_ssnds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -55,7 +51,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst real(psb_spk_), allocatable :: dat_(:) @@ -65,12 +61,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_real_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_ssnds - subroutine psb_ssndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_ssndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -79,23 +74,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_real_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_ssndv - subroutine psb_ssndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_ssndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -104,13 +98,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m real(psb_spk_), allocatable :: dat_(:) integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else @@ -128,12 +122,11 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_real_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_ssndm - subroutine psb_srcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_srcvs(ctxt,dat,src) #ifdef MPI_MOD use mpi #endif @@ -141,21 +134,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,psb_mpi_r_spk_,src,psb_real_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_srcvs - subroutine psb_srcvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_srcvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -164,22 +157,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_srcvv - subroutine psb_srcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_srcvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -188,14 +181,14 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt real(psb_spk_), intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m real(psb_spk_), allocatable :: dat_(:) integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_mpk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else @@ -205,11 +198,13 @@ contains n_ = size(dat,2) call mpi_type_vector(n_,m_,ld,psb_mpi_r_spk_,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + icomm = psb_get_mpi_comm(ctxt) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_real_tag,ictxt,status,info) + & psb_real_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else - call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -218,90 +213,4 @@ contains #endif end subroutine psb_srcvm - - subroutine psb_ssnds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_ssnds_ec - - subroutine psb_ssndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_ssndv_ec - - subroutine psb_ssndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_ssndm_ec - - subroutine psb_srcvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_srcvs_ec - - subroutine psb_srcvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_srcvv_ec - - subroutine psb_srcvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_srcvm_ec - - end module psi_s_p2p_mod diff --git a/base/modules/penv/psi_z_collective_mod.F90 b/base/modules/penv/psi_z_collective_mod.F90 index 8a58ffb5..80c9213a 100644 --- a/base/modules/penv/psi_z_collective_mod.F90 +++ b/base/modules/penv/psi_z_collective_mod.F90 @@ -31,28 +31,22 @@ ! module psi_z_collective_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_sum - module procedure psb_zsums, psb_zsumv, psb_zsumm, & - & psb_zsums_ec, psb_zsumv_ec, psb_zsumm_ec + module procedure psb_zsums, psb_zsumv, psb_zsumm end interface interface psb_amx - module procedure psb_zamxs, psb_zamxv, psb_zamxm, & - & psb_zamxs_ec, psb_zamxv_ec, psb_zamxm_ec + module procedure psb_zamxs, psb_zamxv, psb_zamxm end interface interface psb_amn - module procedure psb_zamns, psb_zamnv, psb_zamnm, & - & psb_zamns_ec, psb_zamnv_ec, psb_zamnm_ec + module procedure psb_zamns, psb_zamnv, psb_zamnm end interface - interface psb_bcast - module procedure psb_zbcasts, psb_zbcastv, psb_zbcastm, & - & psb_zbcasts_ec, psb_zbcastv_ec, psb_zbcastm_ec + module procedure psb_zbcasts, psb_zbcastv, psb_zbcastm end interface psb_bcast interface psb_scan_sum @@ -71,7 +65,6 @@ module psi_z_collective_mod module procedure psb_z_e_simple_triad_a2av, psb_z_m_simple_triad_a2av end interface psb_simple_triad_a2av - contains ! !!!!!!!!!!!!!!!!!!!!!! @@ -86,7 +79,7 @@ contains ! SUM ! - subroutine psb_zsums(ictxt,dat,root) + subroutine psb_zsums(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -94,34 +87,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_zsums - subroutine psb_zsumv(ictxt,dat,root) + subroutine psb_zsumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -130,42 +123,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_zsumv - subroutine psb_zsumm(ictxt,dat,root) + subroutine psb_zsumm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -174,95 +167,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,icomm,info) end if endif #endif end subroutine psb_zsumm - subroutine psb_zsums_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_zsums_ec - - subroutine psb_zsumv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_zsumv_ec - - subroutine psb_zsumm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_zsumm_ec - - ! ! AMX: Maximum Absolute Value ! - subroutine psb_zamxs(ictxt,dat,root) + subroutine psb_zamxs(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -270,34 +215,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_zamxs - subroutine psb_zamxv(ictxt,dat,root) + subroutine psb_zamxv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -306,42 +251,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) end if endif #endif end subroutine psb_zamxv - subroutine psb_zamxm(ictxt,dat,root) + subroutine psb_zamxm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -350,96 +295,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,icomm,info) end if endif #endif end subroutine psb_zamxm - - subroutine psb_zamxs_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_zamxs_ec - - subroutine psb_zamxv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_zamxv_ec - - subroutine psb_zamxm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_zamxm_ec - - ! ! AMN: Minimum Absolute Value ! - subroutine psb_zamns(ictxt,dat,root) + subroutine psb_zamns(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -447,34 +343,34 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_) :: dat_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) + call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,icomm,info) dat = dat_ else - call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) if (iam == root_) dat = dat_ endif #endif end subroutine psb_zamns - subroutine psb_zamnv(ictxt,dat,root) + subroutine psb_zamnv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -483,42 +379,42 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) else call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) end if endif #endif end subroutine psb_zamnv - subroutine psb_zamnm(ictxt,dat,root) + subroutine psb_zamnm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -527,96 +423,47 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ complex(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = -1 endif + icomm = psb_get_mpi_comm(ctxt) if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,icomm,info) else if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) else call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,icomm,info) end if endif #endif end subroutine psb_zamnm - - subroutine psb_zamns_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_zamns_ec - - subroutine psb_zamnv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_zamnv_ec - - subroutine psb_zamnm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_zamnm_ec - - ! ! BCAST Broadcast ! - subroutine psb_zbcasts(ictxt,dat,root) + subroutine psb_zbcasts(ctxt,dat,root) #ifdef MPI_MOD use mpi #endif @@ -624,29 +471,29 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - call mpi_bcast(dat,1,psb_mpi_c_dpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,1,psb_mpi_c_dpk_,root_,icomm,info) #endif end subroutine psb_zbcasts - subroutine psb_zbcastv(ictxt,dat,root) + subroutine psb_zbcastv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -655,28 +502,27 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,icomm,info) #endif end subroutine psb_zbcastv - subroutine psb_zbcastm(ictxt,dat,root) + subroutine psb_zbcastm(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -685,85 +531,35 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:,:) integer(psb_mpk_), intent(in), optional :: root integer(psb_mpk_) :: root_ - integer(psb_mpk_) :: iam, np, info + integer(psb_mpk_) :: iam, np, info, icomm integer(psb_ipk_) :: iinfo #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (present(root)) then root_ = root else root_ = psb_root_ endif - - call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,icomm,info) #endif end subroutine psb_zbcastm - - subroutine psb_zbcasts_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_zbcasts_ec - - subroutine psb_zbcastv_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_zbcastv_ec - - subroutine psb_zbcastm_ec(ictxt,dat,root) - implicit none - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_epk_), intent(in), optional :: root - integer(psb_mpk_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_bcast(ictxt_,dat,root_) - else - call psb_bcast(ictxt_,dat) - end if - end subroutine psb_zbcastm_ec - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SCAN ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine psb_zscan_sums(ictxt,dat) + subroutine psb_zscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -771,23 +567,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat complex(psb_dpk_) :: dat_ integer(psb_ipk_) :: iam, np, info integer(psb_mpk_) :: minfo, icomm - #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_scan(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,icomm,minfo) dat = dat_ #endif end subroutine psb_zscan_sums - subroutine psb_zexscan_sums(ictxt,dat) + subroutine psb_zexscan_sums(ctxt,dat) #ifdef MPI_MOD use mpi #endif @@ -795,7 +590,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat complex(psb_dpk_) :: dat_ integer(psb_ipk_) :: iam, np, info @@ -803,8 +598,8 @@ contains #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call mpi_exscan(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,icomm,minfo) dat = dat_ #else @@ -812,7 +607,7 @@ contains #endif end subroutine psb_zexscan_sums - subroutine psb_zscan_sumv(ictxt,dat,root) + subroutine psb_zscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -821,7 +616,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -830,8 +625,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -839,7 +634,7 @@ contains #endif end subroutine psb_zscan_sumv - subroutine psb_zexscan_sumv(ictxt,dat,root) + subroutine psb_zexscan_sumv(ctxt,dat,root) use psb_realloc_mod #ifdef MPI_MOD use mpi @@ -848,7 +643,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(in), optional :: root integer(psb_mpk_) :: root_ @@ -857,8 +652,8 @@ contains integer(psb_mpk_) :: minfo, icomm #if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + call psb_info(ctxt,iam,np) + icomm = psb_get_mpi_comm(ctxt) call psb_realloc(size(dat),dat_,info) dat_ = dat if (info == psb_success_) & @@ -869,18 +664,17 @@ contains end subroutine psb_zexscan_sumv subroutine psb_z_simple_a2av(valsnd,sdsz,bsdindx,& - & valrcv,rvsz,brvindx,ictxt,info) + & valrcv,rvsz,brvindx,ctxt,info) use psi_z_p2p_mod implicit none complex(psb_dpk_), intent(in) :: valsnd(:) complex(psb_dpk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then idx = bsdindx(ip+1) - call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + call psb_snd(ctxt,valsnd(idx+1:idx+sz),ip) end if end do @@ -899,14 +693,14 @@ contains sz = rvsz(ip+1) if (sz > 0) then idx = brvindx(ip+1) - call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + call psb_rcv(ctxt,valrcv(idx+1:idx+sz),ip) end if end do end subroutine psb_z_simple_a2av subroutine psb_z_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -919,7 +713,7 @@ contains complex(psb_dpk_), intent(out) :: valrcv(:) integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -927,9 +721,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_dcomplex_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -961,7 +755,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_dcomplex_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& @@ -989,7 +783,7 @@ contains end subroutine psb_z_m_simple_triad_a2av subroutine psb_z_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & valrcv,iarcv,jarcv,rvsz,brvindx,ctxt,info) #ifdef MPI_MOD use mpi #endif @@ -1002,7 +796,7 @@ contains complex(psb_dpk_), intent(out) :: valrcv(:) integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(out) :: info !Local variables @@ -1010,9 +804,9 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) - icomm = psb_get_mpi_comm(ictxt) + icomm = psb_get_mpi_comm(ctxt) if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then - prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = brvindx(ip+1) p2ptag = psb_dcomplex_tag call mpi_irecv(valrcv(idx+1:idx+sz),sz,& @@ -1044,7 +838,7 @@ contains do ip = 0, np-1 sz = sdsz(ip+1) if (sz > 0) then - if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ctxt,ip) idx = bsdindx(ip+1) p2ptag = psb_dcomplex_tag call mpi_send(valsnd(idx+1:idx+sz),sz,& diff --git a/base/modules/penv/psi_z_p2p_mod.F90 b/base/modules/penv/psi_z_p2p_mod.F90 index b72b0ae6..cf12d978 100644 --- a/base/modules/penv/psi_z_p2p_mod.F90 +++ b/base/modules/penv/psi_z_p2p_mod.F90 @@ -32,22 +32,18 @@ module psi_z_p2p_mod use psi_penv_mod - use psi_comm_buffers_mod interface psb_snd - module procedure psb_zsnds, psb_zsndv, psb_zsndm, & - & psb_zsnds_ec, psb_zsndv_ec, psb_zsndm_ec + module procedure psb_zsnds, psb_zsndv, psb_zsndm end interface interface psb_rcv - module procedure psb_zrcvs, psb_zrcvv, psb_zrcvm, & - & psb_zrcvs_ec, psb_zrcvv_ec, psb_zrcvm_ec + module procedure psb_zrcvs, psb_zrcvv, psb_zrcvm end interface contains - subroutine psb_zsnds(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_zsnds(ctxt,dat,dst) #ifdef MPI_MOD use mpi #endif @@ -55,7 +51,7 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(in) :: dat integer(psb_mpk_), intent(in) :: dst complex(psb_dpk_), allocatable :: dat_(:) @@ -65,12 +61,11 @@ contains #else allocate(dat_(1), stat=info) dat_(1) = dat - call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_zsnds - subroutine psb_zsndv(ictxt,dat,dst) - use psi_comm_buffers_mod + subroutine psb_zsndv(ctxt,dat,dst) #ifdef MPI_MOD use mpi @@ -79,23 +74,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(in) :: dat(:) integer(psb_mpk_), intent(in) :: dst complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else allocate(dat_(size(dat)), stat=info) dat_(:) = dat(:) - call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_zsndv - subroutine psb_zsndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod + subroutine psb_zsndm(ctxt,dat,dst,m) #ifdef MPI_MOD use mpi @@ -104,13 +98,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(in) :: dat(:,:) integer(psb_mpk_), intent(in) :: dst integer(psb_ipk_), intent(in), optional :: m complex(psb_dpk_), allocatable :: dat_(:) integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info #if defined(SERIAL_MPI) #else @@ -128,12 +122,11 @@ contains k = k + 1 end do end do - call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) + call psi_snd(ctxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) #endif end subroutine psb_zsndm - subroutine psb_zrcvs(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_zrcvs(ctxt,dat,src) #ifdef MPI_MOD use mpi #endif @@ -141,21 +134,21 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(out) :: dat integer(psb_mpk_), intent(in) :: src - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) ! do nothing #else - call mpi_recv(dat,1,psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,1,psb_mpi_c_dpk_,src,psb_dcomplex_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_zrcvs - subroutine psb_zrcvv(ictxt,dat,src) - use psi_comm_buffers_mod + subroutine psb_zrcvv(ctxt,dat,src) #ifdef MPI_MOD use mpi @@ -164,22 +157,22 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(out) :: dat(:) integer(psb_mpk_), intent(in) :: src complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpk_) :: info + integer(psb_mpk_) :: info, icomm integer(psb_mpk_) :: status(mpi_status_size) #if defined(SERIAL_MPI) #else - call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,icomm,status,info) call psb_test_nodes(psb_mesg_queue) #endif end subroutine psb_zrcvv - subroutine psb_zrcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod + subroutine psb_zrcvm(ctxt,dat,src,m) #ifdef MPI_MOD use mpi @@ -188,14 +181,14 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt complex(psb_dpk_), intent(out) :: dat(:,:) integer(psb_mpk_), intent(in) :: src integer(psb_ipk_), intent(in), optional :: m complex(psb_dpk_), allocatable :: dat_(:) integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type integer(psb_mpk_) :: i,j,k - integer(psb_mpk_) :: status(mpi_status_size) + integer(psb_mpk_) :: status(mpi_status_size), icomm #if defined(SERIAL_MPI) ! What should we do here?? #else @@ -205,11 +198,13 @@ contains n_ = size(dat,2) call mpi_type_vector(n_,m_,ld,psb_mpi_c_dpk_,mp_rcv_type,info) if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + icomm = psb_get_mpi_comm(ctxt) if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_dcomplex_tag,ictxt,status,info) + & psb_dcomplex_tag,icomm,status,info) if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) else - call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) + icomm = psb_get_mpi_comm(ctxt) + call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,icomm,status,info) end if if (info /= mpi_success) then write(psb_err_unit,*) 'Error in psb_recv', info @@ -218,90 +213,4 @@ contains #endif end subroutine psb_zrcvm - - subroutine psb_zsnds_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_zsnds_ec - - subroutine psb_zsndv_ec(ictxt,dat,dst) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_zsndv_ec - - subroutine psb_zsndm_ec(ictxt,dat,dst,m) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - integer(psb_epk_), intent(in) :: dst - - integer(psb_mpk_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_zsndm_ec - - subroutine psb_zrcvs_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_zrcvs_ec - - subroutine psb_zrcvv_ec(ictxt,dat,src) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat(:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_zrcvv_ec - - subroutine psb_zrcvm_ec(ictxt,dat,src,m) - - integer(psb_epk_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat(:,:) - integer(psb_epk_), intent(in) :: src - - integer(psb_mpk_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_zrcvm_ec - - end module psi_z_p2p_mod diff --git a/base/modules/psb_cbind_const_mod.F90 b/base/modules/psb_cbind_const_mod.F90 index 2b4bdf69..a20258ac 100644 --- a/base/modules/psb_cbind_const_mod.F90 +++ b/base/modules/psb_cbind_const_mod.F90 @@ -32,6 +32,7 @@ module psb_cbind_const_mod use iso_c_binding + use psb_const_mod integer, parameter :: psb_c_mpk_ = c_int32_t #if defined(IPK4) && defined(LPK4) @@ -48,5 +49,4 @@ module psb_cbind_const_mod integer, parameter :: psb_c_lpk_ = -1 #endif integer, parameter :: psb_c_epk_ = c_int64_t - end module psb_cbind_const_mod diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 26a100a7..dee01457 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -78,7 +78,7 @@ module psb_const_mod ! ! Additional rules: ! 1. MPI related stuff is always MPK - ! 2. ICTXT,IAM,NP: should we have two versions of everything, + ! 2. ctxt,IAM,NP: should we have two versions of everything, ! one with MPK the other with EPK? ! 3. INFO, ERR_ACT, IERR etc are always IPK ! 4. For the array version of things, where it makes sense @@ -315,4 +315,23 @@ module psb_const_mod integer(psb_ipk_), parameter, public :: psb_err_invalid_preci_=5003 integer(psb_ipk_), parameter, public :: psb_err_invalid_preca_=5004 + + type psb_ctxt_type + integer(psb_mpk_), allocatable :: ctxt + end type psb_ctxt_type + +contains + + function psb_cmp_ctxt(ctxt1, ctxt2) result(res) + type(psb_ctxt_type), intent(in) :: ctxt1, ctxt2 + logical :: res + + res = .false. + if (.not.allocated(ctxt1%ctxt).and.(.not.allocated(ctxt2%ctxt))) & + & res = .true. + if (allocated(ctxt1%ctxt).and.allocated(ctxt2%ctxt)) & + & res = (ctxt1%ctxt == ctxt2%ctxt) + + end function psb_cmp_ctxt + end module psb_const_mod diff --git a/base/modules/psb_error_impl.F90 b/base/modules/psb_error_impl.F90 index 1073f24d..b85c48e9 100644 --- a/base/modules/psb_error_impl.F90 +++ b/base/modules/psb_error_impl.F90 @@ -1,23 +1,23 @@ ! checks wether an error has occurred on one of the porecesses in the execution pool -subroutine psb_errcomm_i(ictxt, err) +subroutine psb_errcomm_i(ctxt, err) use psb_error_mod, psb_protect_name => psb_errcomm use psb_penv_mod - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout):: err + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(inout) :: err - if (psb_get_global_checks()) call psb_amx(ictxt, err) + if (psb_get_global_checks()) call psb_amx(ctxt, err) end subroutine psb_errcomm_i #if defined(IPK8) -subroutine psb_errcomm_m(ictxt, err) +subroutine psb_errcomm_m(ctxt, err) use psb_error_mod, psb_protect_name => psb_errcomm use psb_penv_mod - integer(psb_mpk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout):: err + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(inout) :: err - if (psb_get_global_checks()) call psb_amx(ictxt, err) + if (psb_get_global_checks()) call psb_amx(ctxt, err) end subroutine psb_errcomm_m #endif @@ -37,30 +37,30 @@ subroutine psb_ser_error_handler(err_act) return end subroutine psb_ser_error_handler -subroutine psb_par_error_handler(ictxt,err_act) +subroutine psb_par_error_handler(ctxt,err_act) use psb_error_mod, psb_protect_name => psb_par_error_handler use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: err_act + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: err_act call psb_erractionrestore(err_act) if (err_act == psb_act_print_) & - & call psb_error(ictxt, abrt=.false.) + & call psb_error(ctxt, abrt=.false.) if (err_act == psb_act_abort_) & - & call psb_error(ictxt, abrt=.true.) + & call psb_error(ctxt, abrt=.true.) return end subroutine psb_par_error_handler -subroutine psb_par_error_print_stack(ictxt) +subroutine psb_par_error_print_stack(ctxt) use psb_error_mod, psb_protect_name => psb_par_error_print_stack use psb_penv_mod - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt - call psb_error(ictxt, abrt=.false.) + call psb_error(ctxt, abrt=.false.) end subroutine psb_par_error_print_stack @@ -79,8 +79,8 @@ subroutine psb_serror() use psb_error_mod implicit none integer(psb_ipk_) :: err_c - character(len=20) :: r_name - character(len=40) :: a_e_d + character(len=20) :: r_name + character(len=40) :: a_e_d integer(psb_epk_) :: e_e_d(5) if (psb_errstatus_fatal()) then @@ -111,25 +111,24 @@ end subroutine psb_serror ! handles the occurence of an error in a parallel routine -subroutine psb_perror(ictxt,abrt) +subroutine psb_perror(ctxt,abrt) use psb_const_mod use psb_error_mod use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(in), optional :: abrt - - integer(psb_ipk_) :: err_c - character(len=20) :: r_name - character(len=40) :: a_e_d - integer(psb_epk_) :: e_e_d(5) - integer(psb_mpk_) :: iictxt, iam, np + type(psb_ctxt_type), intent(in) :: ctxt + logical, intent(in), optional :: abrt + + integer(psb_ipk_) :: err_c + character(len=20) :: r_name + character(len=40) :: a_e_d + integer(psb_epk_) :: e_e_d(5) + integer(psb_mpk_) :: iam, np logical :: abrt_ abrt_=.true. if (present(abrt)) abrt_=abrt - iictxt = ictxt - call psb_info(iictxt,iam,np) + call psb_info(ctxt,iam,np) if (psb_errstatus_fatal()) then if (psb_get_errverbosity() > 1) then @@ -144,7 +143,7 @@ subroutine psb_perror(ictxt,abrt) flush(psb_err_unit) #endif - if (abrt_) call psb_abort(iictxt,-1) + if (abrt_) call psb_abort(ctxt,-1) else @@ -157,7 +156,7 @@ subroutine psb_perror(ictxt,abrt) flush(psb_err_unit) #endif - if (abrt_) call psb_abort(iictxt,-1) + if (abrt_) call psb_abort(ctxt,-1) end if end if diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index df76dd20..fe12fca4 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -31,7 +31,7 @@ ! module psb_error_mod use psb_const_mod - + integer(psb_ipk_), parameter, public :: psb_act_ret_=0 integer(psb_ipk_), parameter, public :: psb_act_print_=1 integer(psb_ipk_), parameter, public :: psb_act_abort_=2 @@ -71,9 +71,9 @@ module psb_error_mod import :: psb_ipk_ integer(psb_ipk_), intent(inout) :: err_act end subroutine psb_ser_error_handler - subroutine psb_par_error_handler(ictxt,err_act) - import :: psb_ipk_,psb_mpk_ - integer(psb_ipk_), intent(in) :: ictxt + subroutine psb_par_error_handler(ctxt,err_act) + import :: psb_ipk_,psb_mpk_, psb_ctxt_type + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: err_act end subroutine psb_par_error_handler end interface @@ -81,18 +81,18 @@ module psb_error_mod interface psb_error subroutine psb_serror() end subroutine psb_serror - subroutine psb_perror(ictxt,abrt) - import :: psb_ipk_ - integer(psb_ipk_), intent(in) :: ictxt + subroutine psb_perror(ctxt,abrt) + import :: psb_ipk_, psb_ctxt_type + type(psb_ctxt_type), intent(in) :: ctxt logical, intent(in), optional :: abrt end subroutine psb_perror end interface interface psb_error_print_stack - subroutine psb_par_error_print_stack(ictxt) - import :: psb_ipk_ - integer(psb_ipk_), intent(in) :: ictxt + subroutine psb_par_error_print_stack(ctxt) + import :: psb_ipk_, psb_ctxt_type + type(psb_ctxt_type), intent(in) :: ctxt end subroutine psb_par_error_print_stack subroutine psb_ser_error_print_stack() end subroutine psb_ser_error_print_stack @@ -100,16 +100,16 @@ module psb_error_mod interface psb_errcomm #if defined(IPK8) - subroutine psb_errcomm_m(ictxt, err) - import :: psb_ipk_, psb_mpk_ - integer(psb_mpk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout):: err + subroutine psb_errcomm_m(ctxt, err) + import :: psb_ipk_, psb_mpk_, psb_ctxt_type + type(pxb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(inout) :: err end subroutine psb_errcomm_m #endif - subroutine psb_errcomm_i(ictxt, err) - import :: psb_ipk_ - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout):: err + subroutine psb_errcomm_i(ctxt, err) + import :: psb_ipk_, psb_ctxt_type + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(inout) :: err end subroutine psb_errcomm_i end interface psb_errcomm diff --git a/base/modules/psb_timers_mod.f90 b/base/modules/psb_timers_mod.f90 index 18107d6d..6bf95466 100644 --- a/base/modules/psb_timers_mod.f90 +++ b/base/modules/psb_timers_mod.f90 @@ -95,9 +95,9 @@ contains end subroutine print_timer - subroutine psb_print_timers(ictxt, idx, proc, global, iout) + subroutine psb_print_timers(ctxt, idx, proc, global, iout) implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in), optional :: idx, proc, iout logical, optional :: global ! @@ -108,7 +108,7 @@ contains real(psb_dpk_), allocatable :: ptimers(:,:) logical :: global_ - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (present(global)) then global_ = global else @@ -132,10 +132,10 @@ contains allocate(ptimers(timer_entries_,size(timers,2)),stat=info) if (info /= 0) then write(0,*) 'Error while trying to allocate temporary ',info - call psb_abort(ictxt) + call psb_abort(ctxt) end if ptimers = timers - call psb_max(ictxt,ptimers) + call psb_max(ctxt,ptimers) if (me == psb_root_) then do i=idxmin_, idxmax_ call print_timer(me, ptimers(:,i), timers_descr(i), iout) @@ -280,7 +280,7 @@ contains use psb_error_mod implicit none ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len + integer(psb_ipk_),Intent(in) :: len type(psb_string_item),allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info integer(psb_ipk_), optional, intent(in) :: lb diff --git a/base/modules/psi_i_mod.F90 b/base/modules/psi_i_mod.F90 index 5eebad41..e8cf2706 100644 --- a/base/modules/psi_i_mod.F90 +++ b/base/modules/psi_i_mod.F90 @@ -38,17 +38,6 @@ module psi_i_mod use psb_i_base_multivect_mod, only : psb_i_base_multivect_type use psi_i_comm_v_mod - interface psi_compute_size - subroutine psi_i_compute_size(desc_data,& - & index_in, dl_lda, info) - import - implicit none - integer(psb_ipk_) :: info - integer(psb_ipk_) :: dl_lda - integer(psb_ipk_) :: desc_data(:), index_in(:) - end subroutine psi_i_compute_size - end interface - interface psi_crea_bnd_elem subroutine psi_i_crea_bnd_elem(bndel,desc_a,info) import @@ -95,53 +84,46 @@ module psi_i_mod end interface interface psi_sort_dl - subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ictxt,info) + subroutine psi_i_csr_sort_dl(dl_ptr,c_dep_list,l_dep_list,ctxt,info) import implicit none integer(psb_ipk_), intent(in) :: c_dep_list(:), dl_ptr(0:) integer(psb_ipk_), intent(inout) :: l_dep_list(0:) - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: info end subroutine psi_i_csr_sort_dl end interface interface psi_extract_dep_list - subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& + subroutine psi_i_extract_dep_list(ctxt,is_bld,is_upd,desc_str,dep_list,& & length_dl,dl_lda,mode,info) import implicit none - logical, intent(in) :: is_bld, is_upd - integer(psb_ipk_), intent(in) :: ictxt, mode - integer(psb_ipk_), intent(out) :: dl_lda - integer(psb_ipk_), intent(in) :: desc_str(*) + logical, intent(in) :: is_bld, is_upd + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_), intent(in) :: mode + integer(psb_ipk_), intent(out) :: dl_lda + integer(psb_ipk_), intent(in) :: desc_str(*) integer(psb_ipk_), allocatable, intent(out) :: dep_list(:,:), length_dl(:) integer(psb_ipk_), intent(out) :: info end subroutine psi_i_extract_dep_list end interface interface psi_bld_glb_dep_list - subroutine psi_i_bld_glb_dep_list(ictxt,loc_dl,length_dl,dep_list,dl_lda,info) + subroutine psi_i_bld_glb_dep_list(ctxt,loc_dl,length_dl,c_dep_list,dl_ptr,info) import - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dl_lda - integer(psb_ipk_), intent(in) :: loc_dl(:), length_dl(0:) - integer(psb_ipk_), allocatable, intent(out) :: dep_list(:,:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_i_bld_glb_dep_list - subroutine psi_i_bld_glb_csr_dep_list(ictxt,loc_dl,length_dl,c_dep_list,dl_ptr,info) - import - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: loc_dl(:), length_dl(0:) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: loc_dl(:), length_dl(0:) integer(psb_ipk_), allocatable, intent(out) :: c_dep_list(:), dl_ptr(:) integer(psb_ipk_), intent(out) :: info - end subroutine psi_i_bld_glb_csr_dep_list + end subroutine psi_i_bld_glb_dep_list end interface interface psi_extract_loc_dl - subroutine psi_i_xtr_loc_dl(ictxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) + subroutine psi_i_xtr_loc_dl(ctxt,is_bld,is_upd,desc_str,loc_dl,length_dl,info) import logical, intent(in) :: is_bld, is_upd - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: desc_str(:) integer(psb_ipk_), allocatable, intent(out) :: loc_dl(:), length_dl(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index 76225758..5e889da2 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -128,6 +128,7 @@ module psb_c_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_c_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_c_free procedure, pass(a) :: trim => psb_c_trim procedure, pass(a) :: csput_a => psb_c_csput_a @@ -326,6 +327,7 @@ module psb_c_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_lc_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_lc_free procedure, pass(a) :: trim => psb_lc_trim procedure, pass(a) :: csput_a => psb_lc_csput_a @@ -604,12 +606,14 @@ module psb_c_mat_mod end interface interface - subroutine psb_c_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_cspmat_type + subroutine psb_c_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_c_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_c_csall end interface @@ -1384,12 +1388,14 @@ module psb_c_mat_mod end interface interface - subroutine psb_lc_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + subroutine psb_lc_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_lc_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_lc_csall end interface diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index 878d099f..caf03994 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -128,6 +128,7 @@ module psb_d_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_d_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_d_free procedure, pass(a) :: trim => psb_d_trim procedure, pass(a) :: csput_a => psb_d_csput_a @@ -326,6 +327,7 @@ module psb_d_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_ld_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_ld_free procedure, pass(a) :: trim => psb_ld_trim procedure, pass(a) :: csput_a => psb_ld_csput_a @@ -604,12 +606,14 @@ module psb_d_mat_mod end interface interface - subroutine psb_d_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_dspmat_type + subroutine psb_d_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_d_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_d_csall end interface @@ -1384,12 +1388,14 @@ module psb_d_mat_mod end interface interface - subroutine psb_ld_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + subroutine psb_ld_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_ld_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_ld_csall end interface diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index 3553e96b..8e3934b8 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -128,6 +128,7 @@ module psb_s_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_s_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_s_free procedure, pass(a) :: trim => psb_s_trim procedure, pass(a) :: csput_a => psb_s_csput_a @@ -326,6 +327,7 @@ module psb_s_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_ls_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_ls_free procedure, pass(a) :: trim => psb_ls_trim procedure, pass(a) :: csput_a => psb_ls_csput_a @@ -604,12 +606,14 @@ module psb_s_mat_mod end interface interface - subroutine psb_s_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_sspmat_type + subroutine psb_s_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_s_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_s_csall end interface @@ -1384,12 +1388,14 @@ module psb_s_mat_mod end interface interface - subroutine psb_ls_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + subroutine psb_ls_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_ls_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_ls_csall end interface diff --git a/base/modules/serial/psb_serial_mod.f90 b/base/modules/serial/psb_serial_mod.f90 index 2f2154e0..627b318e 100644 --- a/base/modules/serial/psb_serial_mod.f90 +++ b/base/modules/serial/psb_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,8 +27,8 @@ ! 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. -! -! +! +! module psb_serial_mod use psb_const_mod use psb_error_mod @@ -66,9 +66,42 @@ module psb_serial_mod real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psb_d_nspaxpby + subroutine psb_s_nspaxpby(nz,iz,z,alpha, nx, ix, x, beta, ny,iy,y,info) + use psb_const_mod + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_spk_), intent (out) :: z(:) + integer(psb_ipk_), intent(in) :: nx, ny + integer(psb_ipk_), intent(in) :: ix(:), iy(:) + real(psb_spk_), intent (in) :: x(:), y(:) + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_nspaxpby + subroutine psb_c_nspaxpby(nz,iz,z,alpha, nx, ix, x, beta, ny,iy,y,info) + use psb_const_mod + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_spk_), intent (out) :: z(:) + integer(psb_ipk_), intent(in) :: nx, ny + integer(psb_ipk_), intent(in) :: ix(:), iy(:) + complex(psb_spk_), intent (in) :: x(:), y(:) + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_nspaxpby + subroutine psb_z_nspaxpby(nz,iz,z,alpha, nx, ix, x, beta, ny,iy,y,info) + use psb_const_mod + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_dpk_), intent (out) :: z(:) + integer(psb_ipk_), intent(in) :: nx, ny + integer(psb_ipk_), intent(in) :: ix(:), iy(:) + complex(psb_dpk_), intent (in) :: x(:), y(:) + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_nspaxpby end interface psb_nspaxpby - interface + interface subroutine symbmm (n, m, l, ia, ja, diaga, & & ib, jb, diagb, ic, jc, diagc, index) import :: psb_ipk_ @@ -84,7 +117,7 @@ module psb_serial_mod integer(psb_lpk_), allocatable :: ic(:),jc(:) end subroutine lsymbmm end interface - + contains @@ -103,13 +136,13 @@ contains elemental function psb_cnrm1(x) result(res) complex(psb_spk_), intent(in) :: x real(psb_spk_) :: res - res = abs( real( x ) ) + abs( aimag( x ) ) + res = abs( real( x ) ) + abs( aimag( x ) ) end function psb_cnrm1 elemental function psb_znrm1(x) result(res) complex(psb_dpk_), intent(in) :: x real(psb_dpk_) :: res - res = abs( real( x ) ) + abs( aimag( x ) ) + res = abs( real( x ) ) + abs( aimag( x ) ) end function psb_znrm1 elemental function psb_sminreal(x) result(res) @@ -127,13 +160,13 @@ contains elemental function psb_cminreal(x) result(res) complex(psb_spk_), intent(in) :: x real(psb_spk_) :: res - res = min( real( x ) , aimag( x ) ) + res = min( real( x ) , aimag( x ) ) end function psb_cminreal elemental function psb_zminreal(x) result(res) complex(psb_dpk_), intent(in) :: x real(psb_dpk_) :: res - res = min( real( x ) , aimag( x ) ) + res = min( real( x ) , aimag( x ) ) end function psb_zminreal @@ -197,7 +230,7 @@ contains ! .. executable statements .. ! if( n <= 0 ) return - if( incx == 1 .and. incy == 1 ) then + if( incx == 1 .and. incy == 1 ) then ! ! code for both increments equal to 1 ! @@ -232,7 +265,7 @@ contains real(psb_spk_) norm,scale complex(psb_spk_) alpha ! - if (cabs(ca) == 0.0) then + if (cabs(ca) == 0.0) then ! c = 0.0d0 s = (1.0,0.0) @@ -316,7 +349,7 @@ contains ! .. executable statements .. ! if( n <= 0 ) return - if( incx == 1 .and. incy == 1 ) then + if( incx == 1 .and. incy == 1 ) then ! ! code for both increments equal to 1 ! @@ -351,7 +384,7 @@ contains real(psb_dpk_) norm,scale complex(psb_dpk_) alpha ! - if (cdabs(ca) == 0.0d0) then + if (cdabs(ca) == 0.0d0) then ! c = 0.0d0 s = (1.0d0,0.0d0) @@ -374,4 +407,3 @@ contains end module psb_serial_mod - diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index 35586b3e..ed3338f9 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -128,6 +128,7 @@ module psb_z_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_z_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_z_free procedure, pass(a) :: trim => psb_z_trim procedure, pass(a) :: csput_a => psb_z_csput_a @@ -326,6 +327,7 @@ module psb_z_mat_mod ! Memory/data management procedure, pass(a) :: csall => psb_lz_csall + generic, public :: allocate => csall procedure, pass(a) :: free => psb_lz_free procedure, pass(a) :: trim => psb_lz_trim procedure, pass(a) :: csput_a => psb_lz_csput_a @@ -604,12 +606,14 @@ module psb_z_mat_mod end interface interface - subroutine psb_z_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_zspmat_type + subroutine psb_z_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_z_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_z_csall end interface @@ -1384,12 +1388,14 @@ module psb_z_mat_mod end interface interface - subroutine psb_lz_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + subroutine psb_lz_csall(nr,nc,a,info,nz,type,mold) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_lz_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_lz_csall end interface diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index 81e78d3a..378e146b 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -431,5 +431,21 @@ Module psb_c_tools_mod end function end interface + interface psb_remap + subroutine psb_c_remap(np_remap, desc_in, a_in, & + & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) + import + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_cspmat_type), intent(inout) :: a_in + type(psb_cspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_remap + end interface psb_remap end module psb_c_tools_mod diff --git a/base/modules/tools/psb_cd_tools_mod.F90 b/base/modules/tools/psb_cd_tools_mod.F90 index 3a67d829..df4c02a1 100644 --- a/base/modules/tools/psb_cd_tools_mod.F90 +++ b/base/modules/tools/psb_cd_tools_mod.F90 @@ -190,13 +190,14 @@ module psb_cd_tools_mod interface psb_cdall - subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,& + subroutine psb_cdall(ctxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,& & globalcheck,lidx,usehash) - import :: psb_ipk_, psb_lpk_, psb_desc_type, psb_parts + import :: psb_ipk_, psb_lpk_, psb_desc_type, psb_parts, psb_ctxt_type implicit None procedure(psb_parts) :: parts integer(psb_lpk_), intent(in) :: mg,ng, vl(:) - integer(psb_ipk_), intent(in) :: ictxt, vg(:), lidx(:),nl + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_), intent(in) :: vg(:), lidx(:),nl integer(psb_ipk_), intent(in) :: flag logical, intent(in) :: repl, globalcheck, usehash integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index 76a5bdf2..81c75ece 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -431,5 +431,21 @@ Module psb_d_tools_mod end function end interface + interface psb_remap + subroutine psb_d_remap(np_remap, desc_in, a_in, & + & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) + import + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_dspmat_type), intent(inout) :: a_in + type(psb_dspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_remap + end interface psb_remap end module psb_d_tools_mod diff --git a/base/modules/tools/psb_i_tools_mod.F90 b/base/modules/tools/psb_i_tools_mod.F90 index def96326..5cc6e836 100644 --- a/base/modules/tools/psb_i_tools_mod.F90 +++ b/base/modules/tools/psb_i_tools_mod.F90 @@ -170,5 +170,4 @@ Module psb_i_tools_mod end subroutine psb_iins_multivect end interface - end module psb_i_tools_mod diff --git a/base/modules/tools/psb_l_tools_mod.F90 b/base/modules/tools/psb_l_tools_mod.F90 index b389ef85..56617798 100644 --- a/base/modules/tools/psb_l_tools_mod.F90 +++ b/base/modules/tools/psb_l_tools_mod.F90 @@ -170,5 +170,4 @@ Module psb_l_tools_mod end subroutine psb_lins_multivect end interface - end module psb_l_tools_mod diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index 2b6058da..fa82a53e 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -431,5 +431,21 @@ Module psb_s_tools_mod end function end interface + interface psb_remap + subroutine psb_s_remap(np_remap, desc_in, a_in, & + & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) + import + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_sspmat_type), intent(inout) :: a_in + type(psb_sspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_remap + end interface psb_remap end module psb_s_tools_mod diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index 09997e94..233f2c20 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -431,5 +431,21 @@ Module psb_z_tools_mod end function end interface + interface psb_remap + subroutine psb_z_remap(np_remap, desc_in, a_in, & + & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) + import + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_zspmat_type), intent(inout) :: a_in + type(psb_zspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_remap + end interface psb_remap end module psb_z_tools_mod diff --git a/base/psblas/psb_cabs_vect.f90 b/base/psblas/psb_cabs_vect.f90 index 46e74635..cb192195 100644 --- a/base/psblas/psb_cabs_vect.f90 +++ b/base/psblas/psb_cabs_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_cabs_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_cabs_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_cabs_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 index 21569613..e30ba8fe 100644 --- a/base/psblas/psb_camax.f90 +++ b/base/psblas/psb_camax.f90 @@ -57,7 +57,8 @@ function psb_camax(x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_camax(x,desc_a, info, jx,global) result(res) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -118,12 +119,12 @@ function psb_camax(x,desc_a, info, jx,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_camax @@ -185,7 +186,8 @@ function psb_camaxv (x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -199,9 +201,9 @@ function psb_camaxv (x,desc_a, info,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -242,12 +244,12 @@ function psb_camaxv (x,desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_camaxv @@ -280,7 +282,8 @@ function psb_camax_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -293,9 +296,9 @@ function psb_camax_vect(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -340,12 +343,12 @@ function psb_camax_vect(x, desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -423,9 +427,9 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -465,12 +469,12 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_camaxvs @@ -532,7 +536,8 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx, i, k integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -545,9 +550,9 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -593,12 +598,12 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cmamaxs diff --git a/base/psblas/psb_casum.f90 b/base/psblas/psb_casum.f90 index a0bf5262..7b9b3275 100644 --- a/base/psblas/psb_casum.f90 +++ b/base/psblas/psb_casum.f90 @@ -57,7 +57,8 @@ function psb_casum (x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_casum (x,desc_a, info, jx,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -125,12 +126,12 @@ function psb_casum (x,desc_a, info, jx,global) result(res) res = szero end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_casum @@ -160,7 +161,8 @@ function psb_casum_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, imax, i, idx, ndm integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -174,9 +176,9 @@ function psb_casum_vect(x, desc_a, info,global) result(res) call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -230,12 +232,12 @@ function psb_casum_vect(x, desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -297,7 +299,8 @@ function psb_casumv(x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -310,9 +313,9 @@ function psb_casumv(x,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -361,12 +364,12 @@ function psb_casumv(x,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_casumv @@ -428,7 +431,8 @@ subroutine psb_casumvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -441,9 +445,9 @@ subroutine psb_casumvs(res,x,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -492,12 +496,12 @@ subroutine psb_casumvs(res,x,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt,res) + if (global_) call psb_sum(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_casumvs diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index 6518e730..9ac48603 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -59,7 +59,8 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -69,9 +70,9 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -123,7 +124,7 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -192,7 +193,8 @@ subroutine psb_caxpby_vect_out(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -202,9 +204,9 @@ subroutine psb_caxpby_vect_out(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -269,7 +271,7 @@ subroutine psb_caxpby_vect_out(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -308,7 +310,8 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) complex(psb_spk_), intent(inout) :: y(:,:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, in, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -320,8 +323,8 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -390,7 +393,7 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_caxpby @@ -456,7 +459,8 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) complex(psb_spk_), intent(inout) :: y(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -469,9 +473,9 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -514,7 +518,7 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_caxpbyv @@ -578,7 +582,8 @@ subroutine psb_caxpbyvout(alpha, x, beta,y, z, desc_a,info) complex(psb_spk_), intent(inout) :: z(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -591,9 +596,9 @@ subroutine psb_caxpbyvout(alpha, x, beta,y, z, desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -645,7 +650,7 @@ subroutine psb_caxpbyvout(alpha, x, beta,y, z, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_caxpbyvout @@ -673,7 +678,8 @@ subroutine psb_caddconst_vect(x,b,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -683,9 +689,9 @@ subroutine psb_caddconst_vect(x,b,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -730,7 +736,7 @@ subroutine psb_caddconst_vect(x,b,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_ccmp_vect.f90 b/base/psblas/psb_ccmp_vect.f90 index 367f193b..5de95513 100644 --- a/base/psblas/psb_ccmp_vect.f90 +++ b/base/psblas/psb_ccmp_vect.f90 @@ -41,7 +41,8 @@ subroutine psb_ccmp_vect(x,c,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -51,9 +52,9 @@ subroutine psb_ccmp_vect(x,c,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_ccmp_vect(x,c,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -115,7 +116,8 @@ subroutine psb_ccmp_spmatval(a,val,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -129,8 +131,8 @@ subroutine psb_ccmp_spmatval(a,val,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -144,16 +146,16 @@ subroutine psb_ccmp_spmatval(a,val,tol,desc_a,res,info) res = a%spcmp(val,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ccmp_spmatval @@ -169,7 +171,8 @@ subroutine psb_ccmp_spmat(a,b,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -183,8 +186,8 @@ subroutine psb_ccmp_spmat(a,b,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -200,17 +203,17 @@ subroutine psb_ccmp_spmat(a,b,tol,desc_a,res,info) res = a%spcmp(b,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_cdiv_vect.f90 b/base/psblas/psb_cdiv_vect.f90 index 3e709da4..0fe4594a 100644 --- a/base/psblas/psb_cdiv_vect.f90 +++ b/base/psblas/psb_cdiv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_cdiv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_cdiv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_cdiv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -114,7 +115,8 @@ subroutine psb_cdiv_vect2(x,y,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -124,9 +126,9 @@ subroutine psb_cdiv_vect2(x,y,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -185,7 +187,7 @@ subroutine psb_cdiv_vect2(x,y,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -201,7 +203,8 @@ subroutine psb_cdiv_vect_check(x,y,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -211,9 +214,9 @@ subroutine psb_cdiv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -259,7 +262,7 @@ subroutine psb_cdiv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -276,7 +279,8 @@ subroutine psb_cdiv_vect2_check(x,y,z,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -286,9 +290,9 @@ subroutine psb_cdiv_vect2_check(x,y,z,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -346,7 +350,7 @@ subroutine psb_cdiv_vect2_check(x,y,z,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_cdot.f90 b/base/psblas/psb_cdot.f90 index 5432eb32..ed300b7c 100644 --- a/base/psblas/psb_cdot.f90 +++ b/base/psblas/psb_cdot.f90 @@ -64,7 +64,8 @@ function psb_cdot_vect(x, y, desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -78,8 +79,8 @@ function psb_cdot_vect(x, y, desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -146,12 +147,12 @@ function psb_cdot_vect(x, y, desc_a,info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -187,7 +188,8 @@ function psb_cdot(x, y,desc_a, info, jx, jy,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m complex(psb_spk_) :: cdotc @@ -201,8 +203,8 @@ function psb_cdot(x, y,desc_a, info, jx, jy,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -270,12 +272,12 @@ function psb_cdot(x, y,desc_a, info, jx, jy,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cdot @@ -338,7 +340,8 @@ function psb_cdotv(x, y,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -352,9 +355,9 @@ function psb_cdotv(x, y,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -405,13 +408,13 @@ function psb_cdotv(x, y,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cdotv @@ -474,7 +477,8 @@ subroutine psb_cdotvs(res, x, y,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -488,9 +492,9 @@ subroutine psb_cdotvs(res, x, y,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -539,12 +543,12 @@ subroutine psb_cdotvs(res, x, y,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cdotvs @@ -608,7 +612,8 @@ subroutine psb_cmdots(res, x, y, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -622,9 +627,9 @@ subroutine psb_cmdots(res, x, y, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -685,12 +690,12 @@ subroutine psb_cmdots(res, x, y, desc_a, info,global) ! compute global sum - if (global_) call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cmdots diff --git a/base/psblas/psb_cgetmatinfo.f90 b/base/psblas/psb_cgetmatinfo.F90 similarity index 90% rename from base/psblas/psb_cgetmatinfo.f90 rename to base/psblas/psb_cgetmatinfo.F90 index 9e406c15..fdfb0cba 100644 --- a/base/psblas/psb_cgetmatinfo.f90 +++ b/base/psblas/psb_cgetmatinfo.F90 @@ -37,9 +37,13 @@ function psb_cget_nnz(a,desc_a,info) result(res) use psb_base_mod, psb_protect_name => psb_cget_nnz use psi_mod - use mpi - - implicit none +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif integer(psb_lpk_) :: res type(psb_cspmat_type), intent(in) :: a @@ -47,7 +51,8 @@ function psb_cget_nnz(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja integer(psb_lpk_) :: localnnz character(len=20) :: name, ch_err @@ -59,8 +64,8 @@ function psb_cget_nnz(a,desc_a,info) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -69,12 +74,12 @@ function psb_cget_nnz(a,desc_a,info) result(res) localnnz = a%get_nzeros() - call psb_sum(ictxt,localnnz) + call psb_sum(ctxt,localnnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function diff --git a/base/psblas/psb_cinv_vect.f90 b/base/psblas/psb_cinv_vect.f90 index 27f04681..25589f32 100644 --- a/base/psblas/psb_cinv_vect.f90 +++ b/base/psblas/psb_cinv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_cinv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_cinv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_cinv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -115,7 +116,8 @@ subroutine psb_cinv_vect_check(x,y,desc_a,info,flag) logical :: check ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -125,9 +127,9 @@ subroutine psb_cinv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -176,7 +178,7 @@ subroutine psb_cinv_vect_check(x,y,desc_a,info,flag) check = .TRUE. end if - call psb_lallreduceand(ictxt,check) + call psb_lallreduceand(ctxt,check) if (check) then info = 1_psb_ipk_ @@ -187,7 +189,7 @@ subroutine psb_cinv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_cmlt_vect.f90 b/base/psblas/psb_cmlt_vect.f90 index e2b09270..9b4037bf 100644 --- a/base/psblas/psb_cmlt_vect.f90 +++ b/base/psblas/psb_cmlt_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_cmlt_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_cmlt_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_cmlt_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -120,7 +121,8 @@ subroutine psb_cmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) character(len=1), intent(in), optional :: conjgx, conjgy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -130,9 +132,9 @@ subroutine psb_cmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -191,7 +193,7 @@ subroutine psb_cmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index d357c951..8a803a4d 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -60,7 +60,8 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -74,9 +75,9 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -126,12 +127,12 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cnrm2 @@ -195,7 +196,8 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_spk_) :: scnrm2, dd @@ -209,9 +211,9 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -254,12 +256,12 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cnrm2v @@ -291,7 +293,8 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -305,9 +308,9 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -360,12 +363,12 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cnrm2_vect @@ -398,7 +401,8 @@ function psb_cnrm2_weight_vect(x,w, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -412,9 +416,9 @@ function psb_cnrm2_weight_vect(x,w, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -467,12 +471,12 @@ function psb_cnrm2_weight_vect(x,w, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cnrm2_weight_vect @@ -508,7 +512,8 @@ function psb_cnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -522,9 +527,9 @@ function psb_cnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -577,12 +582,12 @@ function psb_cnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cnrm2_weightmask_vect @@ -645,7 +650,8 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -659,9 +665,9 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -706,13 +712,13 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cnrm2vs diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 index 0abece53..f28719ea 100644 --- a/base/psblas/psb_cnrmi.f90 +++ b/base/psblas/psb_cnrmi.f90 @@ -53,7 +53,8 @@ function psb_cnrmi(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: m, n, ia, ja logical :: global_ @@ -66,9 +67,9 @@ function psb_cnrmi(a,desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -113,12 +114,12 @@ function psb_cnrmi(a,desc_a,info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cnrmi diff --git a/base/psblas/psb_cspmm.f90 b/base/psblas/psb_cspmm.f90 index 5a059647..fd8a9c39 100644 --- a/base/psblas/psb_cspmm.f90 +++ b/base/psblas/psb_cspmm.f90 @@ -71,7 +71,8 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja @@ -92,8 +93,8 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -250,12 +251,12 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cspmv_vect @@ -309,7 +310,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik @@ -330,9 +332,9 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -581,7 +583,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cspmm @@ -656,7 +658,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -677,8 +680,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -886,12 +889,12 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cspmv diff --git a/base/psblas/psb_cspnrm1.f90 b/base/psblas/psb_cspnrm1.f90 index c49fdcc1..92b04ebb 100644 --- a/base/psblas/psb_cspnrm1.f90 +++ b/base/psblas/psb_cspnrm1.f90 @@ -53,7 +53,8 @@ function psb_cspnrm1(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, nr,nc,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, nr,nc,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ @@ -65,9 +66,9 @@ function psb_cspnrm1(a,desc_a,info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -129,12 +130,12 @@ function psb_cspnrm1(a,desc_a,info,global) result(res) res = szero end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_cspnrm1 diff --git a/base/psblas/psb_cspsm.f90 b/base/psblas/psb_cspsm.f90 index 3fc8138c..da99b8e9 100644 --- a/base/psblas/psb_cspsm.f90 +++ b/base/psblas/psb_cspsm.f90 @@ -84,7 +84,8 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -103,9 +104,9 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -223,7 +224,7 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cspsv_vect @@ -289,7 +290,8 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: k, jx, jy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -308,9 +310,9 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -476,7 +478,7 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cspsm @@ -533,7 +535,8 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -552,9 +555,9 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -705,7 +708,7 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cspsv diff --git a/base/psblas/psb_cvmlt.f90 b/base/psblas/psb_cvmlt.f90 index 829ce987..a5ee7bbc 100644 --- a/base/psblas/psb_cvmlt.f90 +++ b/base/psblas/psb_cvmlt.f90 @@ -40,7 +40,7 @@ subroutine psb_cvmlt(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + integer(psb_ipk_) :: ctxt, np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +50,9 @@ subroutine psb_cvmlt(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -104,7 +104,7 @@ subroutine psb_cvmlt(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_dabs_vect.f90 b/base/psblas/psb_dabs_vect.f90 index 78f2b75c..0b655d9c 100644 --- a/base/psblas/psb_dabs_vect.f90 +++ b/base/psblas/psb_dabs_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_dabs_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_dabs_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_dabs_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index ea3581d4..490d4ffe 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -57,7 +57,8 @@ function psb_damax(x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_damax(x,desc_a, info, jx,global) result(res) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -118,12 +119,12 @@ function psb_damax(x,desc_a, info, jx,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_damax @@ -185,7 +186,8 @@ function psb_damaxv (x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -199,9 +201,9 @@ function psb_damaxv (x,desc_a, info,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -242,12 +244,12 @@ function psb_damaxv (x,desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_damaxv @@ -280,7 +282,8 @@ function psb_damax_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -293,9 +296,9 @@ function psb_damax_vect(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -340,12 +343,12 @@ function psb_damax_vect(x, desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -423,9 +427,9 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -465,12 +469,12 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_damaxvs @@ -532,7 +536,8 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx, i, k integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -545,9 +550,9 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -593,12 +598,12 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dmamaxs @@ -631,7 +636,8 @@ function psb_dmin_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -644,9 +650,9 @@ function psb_dmin_vect(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -691,12 +697,12 @@ function psb_dmin_vect(x, desc_a, info,global) result(res) end if ! compute global min - if (global_) call psb_min(ictxt, res) + if (global_) call psb_min(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index 5de367f7..ff4399de 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -57,7 +57,8 @@ function psb_dasum (x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_dasum (x,desc_a, info, jx,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -125,12 +126,12 @@ function psb_dasum (x,desc_a, info, jx,global) result(res) res = dzero end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dasum @@ -160,7 +161,8 @@ function psb_dasum_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, imax, i, idx, ndm integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -174,9 +176,9 @@ function psb_dasum_vect(x, desc_a, info,global) result(res) call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -230,12 +232,12 @@ function psb_dasum_vect(x, desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -297,7 +299,8 @@ function psb_dasumv(x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -310,9 +313,9 @@ function psb_dasumv(x,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -361,12 +364,12 @@ function psb_dasumv(x,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dasumv @@ -428,7 +431,8 @@ subroutine psb_dasumvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -441,9 +445,9 @@ subroutine psb_dasumvs(res,x,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -492,12 +496,12 @@ subroutine psb_dasumvs(res,x,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt,res) + if (global_) call psb_sum(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dasumvs diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 550711e4..f2768789 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -59,7 +59,8 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -69,9 +70,9 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -123,7 +124,7 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -192,7 +193,8 @@ subroutine psb_daxpby_vect_out(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -202,9 +204,9 @@ subroutine psb_daxpby_vect_out(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -269,7 +271,7 @@ subroutine psb_daxpby_vect_out(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -308,7 +310,8 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) real(psb_dpk_), intent(inout) :: y(:,:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, in, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -320,8 +323,8 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -390,7 +393,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_daxpby @@ -456,7 +459,8 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) real(psb_dpk_), intent(inout) :: y(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -469,9 +473,9 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -514,7 +518,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_daxpbyv @@ -578,7 +582,8 @@ subroutine psb_daxpbyvout(alpha, x, beta,y, z, desc_a,info) real(psb_dpk_), intent(inout) :: z(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -591,9 +596,9 @@ subroutine psb_daxpbyvout(alpha, x, beta,y, z, desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -645,7 +650,7 @@ subroutine psb_daxpbyvout(alpha, x, beta,y, z, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_daxpbyvout @@ -673,7 +678,8 @@ subroutine psb_daddconst_vect(x,b,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -683,9 +689,9 @@ subroutine psb_daddconst_vect(x,b,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -730,7 +736,7 @@ subroutine psb_daddconst_vect(x,b,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_dcmp_vect.f90 b/base/psblas/psb_dcmp_vect.f90 index 084feeda..b52b34d1 100644 --- a/base/psblas/psb_dcmp_vect.f90 +++ b/base/psblas/psb_dcmp_vect.f90 @@ -41,7 +41,8 @@ subroutine psb_dcmp_vect(x,c,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -51,9 +52,9 @@ subroutine psb_dcmp_vect(x,c,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_dcmp_vect(x,c,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -148,7 +149,8 @@ subroutine psb_dmask_vect(c,x,m,t,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, mm character(len=20) :: name, ch_err @@ -158,9 +160,9 @@ subroutine psb_dmask_vect(c,x,m,t,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -214,12 +216,12 @@ subroutine psb_dmask_vect(c,x,m,t,desc_a,info) call m%mask(c,x,t,info) end if - call psb_lallreduceand(ictxt,t) + call psb_lallreduceand(ctxt,t) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -237,7 +239,8 @@ subroutine psb_dcmp_spmatval(a,val,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -251,8 +254,8 @@ subroutine psb_dcmp_spmatval(a,val,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -266,16 +269,16 @@ subroutine psb_dcmp_spmatval(a,val,tol,desc_a,res,info) res = a%spcmp(val,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dcmp_spmatval @@ -291,7 +294,8 @@ subroutine psb_dcmp_spmat(a,b,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -305,8 +309,8 @@ subroutine psb_dcmp_spmat(a,b,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,17 +326,17 @@ subroutine psb_dcmp_spmat(a,b,tol,desc_a,res,info) res = a%spcmp(b,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_ddiv_vect.f90 b/base/psblas/psb_ddiv_vect.f90 index d5a85913..7f958e19 100644 --- a/base/psblas/psb_ddiv_vect.f90 +++ b/base/psblas/psb_ddiv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_ddiv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_ddiv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_ddiv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -114,7 +115,8 @@ subroutine psb_ddiv_vect2(x,y,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -124,9 +126,9 @@ subroutine psb_ddiv_vect2(x,y,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -185,7 +187,7 @@ subroutine psb_ddiv_vect2(x,y,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -201,7 +203,8 @@ subroutine psb_ddiv_vect_check(x,y,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -211,9 +214,9 @@ subroutine psb_ddiv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -259,7 +262,7 @@ subroutine psb_ddiv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -276,7 +279,8 @@ subroutine psb_ddiv_vect2_check(x,y,z,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -286,9 +290,9 @@ subroutine psb_ddiv_vect2_check(x,y,z,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -346,7 +350,7 @@ subroutine psb_ddiv_vect2_check(x,y,z,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -369,7 +373,8 @@ function psb_dminquotient_vect(x,y,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -382,9 +387,9 @@ function psb_dminquotient_vect(x,y,desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -429,12 +434,12 @@ function psb_dminquotient_vect(x,y,desc_a,info,global) result(res) end if ! compute global min - if (global_) call psb_min(ictxt, res) + if (global_) call psb_min(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index ba1d9619..633c7549 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -64,7 +64,8 @@ function psb_ddot_vect(x, y, desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -78,8 +79,8 @@ function psb_ddot_vect(x, y, desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -146,12 +147,12 @@ function psb_ddot_vect(x, y, desc_a,info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -187,7 +188,8 @@ function psb_ddot(x, y,desc_a, info, jx, jy,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m real(psb_dpk_) :: ddot @@ -201,8 +203,8 @@ function psb_ddot(x, y,desc_a, info, jx, jy,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -270,12 +272,12 @@ function psb_ddot(x, y,desc_a, info, jx, jy,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_ddot @@ -338,7 +340,8 @@ function psb_ddotv(x, y,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -352,9 +355,9 @@ function psb_ddotv(x, y,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -405,13 +408,13 @@ function psb_ddotv(x, y,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_ddotv @@ -474,7 +477,8 @@ subroutine psb_ddotvs(res, x, y,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -488,9 +492,9 @@ subroutine psb_ddotvs(res, x, y,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -539,12 +543,12 @@ subroutine psb_ddotvs(res, x, y,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ddotvs @@ -608,7 +612,8 @@ subroutine psb_dmdots(res, x, y, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -622,9 +627,9 @@ subroutine psb_dmdots(res, x, y, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -685,12 +690,12 @@ subroutine psb_dmdots(res, x, y, desc_a, info,global) ! compute global sum - if (global_) call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dmdots diff --git a/base/psblas/psb_dgetmatinfo.f90 b/base/psblas/psb_dgetmatinfo.F90 similarity index 90% rename from base/psblas/psb_dgetmatinfo.f90 rename to base/psblas/psb_dgetmatinfo.F90 index 2caf8ed4..16a1d3ca 100644 --- a/base/psblas/psb_dgetmatinfo.f90 +++ b/base/psblas/psb_dgetmatinfo.F90 @@ -37,9 +37,13 @@ function psb_dget_nnz(a,desc_a,info) result(res) use psb_base_mod, psb_protect_name => psb_dget_nnz use psi_mod - use mpi - - implicit none +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif integer(psb_lpk_) :: res type(psb_dspmat_type), intent(in) :: a @@ -47,7 +51,8 @@ function psb_dget_nnz(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja integer(psb_lpk_) :: localnnz character(len=20) :: name, ch_err @@ -59,8 +64,8 @@ function psb_dget_nnz(a,desc_a,info) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -69,12 +74,12 @@ function psb_dget_nnz(a,desc_a,info) result(res) localnnz = a%get_nzeros() - call psb_sum(ictxt,localnnz) + call psb_sum(ctxt,localnnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function diff --git a/base/psblas/psb_dinv_vect.f90 b/base/psblas/psb_dinv_vect.f90 index 89b25e38..2159398f 100644 --- a/base/psblas/psb_dinv_vect.f90 +++ b/base/psblas/psb_dinv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_dinv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_dinv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_dinv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -115,7 +116,8 @@ subroutine psb_dinv_vect_check(x,y,desc_a,info,flag) logical :: check ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -125,9 +127,9 @@ subroutine psb_dinv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -176,7 +178,7 @@ subroutine psb_dinv_vect_check(x,y,desc_a,info,flag) check = .TRUE. end if - call psb_lallreduceand(ictxt,check) + call psb_lallreduceand(ctxt,check) if (check) then info = 1_psb_ipk_ @@ -187,7 +189,7 @@ subroutine psb_dinv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_dmlt_vect.f90 b/base/psblas/psb_dmlt_vect.f90 index ac45802f..80a138c1 100644 --- a/base/psblas/psb_dmlt_vect.f90 +++ b/base/psblas/psb_dmlt_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_dmlt_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_dmlt_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_dmlt_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -120,7 +121,8 @@ subroutine psb_dmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) character(len=1), intent(in), optional :: conjgx, conjgy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -130,9 +132,9 @@ subroutine psb_dmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -191,7 +193,7 @@ subroutine psb_dmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 16b18d91..423bebe2 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -60,7 +60,8 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -74,9 +75,9 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -126,12 +127,12 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dnrm2 @@ -195,7 +196,8 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_dpk_) :: dnrm2, dd @@ -209,9 +211,9 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -254,12 +256,12 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dnrm2v @@ -291,7 +293,8 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -305,9 +308,9 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -360,12 +363,12 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dnrm2_vect @@ -398,7 +401,8 @@ function psb_dnrm2_weight_vect(x,w, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -412,9 +416,9 @@ function psb_dnrm2_weight_vect(x,w, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -467,12 +471,12 @@ function psb_dnrm2_weight_vect(x,w, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dnrm2_weight_vect @@ -508,7 +512,8 @@ function psb_dnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -522,9 +527,9 @@ function psb_dnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -577,12 +582,12 @@ function psb_dnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dnrm2_weightmask_vect @@ -645,7 +650,8 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -659,9 +665,9 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -706,13 +712,13 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dnrm2vs diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index a6a97751..e06bc71b 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -53,7 +53,8 @@ function psb_dnrmi(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: m, n, ia, ja logical :: global_ @@ -66,9 +67,9 @@ function psb_dnrmi(a,desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -113,12 +114,12 @@ function psb_dnrmi(a,desc_a,info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dnrmi diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index 1fdf6171..a006c7e9 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -71,7 +71,8 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja @@ -92,8 +93,8 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -250,12 +251,12 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dspmv_vect @@ -309,7 +310,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik @@ -330,9 +332,9 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -581,7 +583,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dspmm @@ -656,7 +658,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -677,8 +680,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -886,12 +889,12 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dspmv diff --git a/base/psblas/psb_dspnrm1.f90 b/base/psblas/psb_dspnrm1.f90 index 9d367615..6bdb4eea 100644 --- a/base/psblas/psb_dspnrm1.f90 +++ b/base/psblas/psb_dspnrm1.f90 @@ -53,7 +53,8 @@ function psb_dspnrm1(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, nr,nc,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, nr,nc,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ @@ -65,9 +66,9 @@ function psb_dspnrm1(a,desc_a,info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -129,12 +130,12 @@ function psb_dspnrm1(a,desc_a,info,global) result(res) res = dzero end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_dspnrm1 diff --git a/base/psblas/psb_dspsm.f90 b/base/psblas/psb_dspsm.f90 index f1a019ad..9e5eeafc 100644 --- a/base/psblas/psb_dspsm.f90 +++ b/base/psblas/psb_dspsm.f90 @@ -84,7 +84,8 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -103,9 +104,9 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -223,7 +224,7 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dspsv_vect @@ -289,7 +290,8 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: k, jx, jy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -308,9 +310,9 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -476,7 +478,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dspsm @@ -533,7 +535,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -552,9 +555,9 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -705,7 +708,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_dspsv diff --git a/base/psblas/psb_dvmlt.f90 b/base/psblas/psb_dvmlt.f90 index ec5325fc..ea76e57a 100644 --- a/base/psblas/psb_dvmlt.f90 +++ b/base/psblas/psb_dvmlt.f90 @@ -40,7 +40,7 @@ subroutine psb_dvmlt(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + integer(psb_ipk_) :: ctxt, np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +50,9 @@ subroutine psb_dvmlt(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -104,7 +104,7 @@ subroutine psb_dvmlt(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_sabs_vect.f90 b/base/psblas/psb_sabs_vect.f90 index 1d4897a9..2eb22d73 100644 --- a/base/psblas/psb_sabs_vect.f90 +++ b/base/psblas/psb_sabs_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_sabs_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_sabs_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_sabs_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 index 30b22fd8..b2858d96 100644 --- a/base/psblas/psb_samax.f90 +++ b/base/psblas/psb_samax.f90 @@ -57,7 +57,8 @@ function psb_samax(x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_samax(x,desc_a, info, jx,global) result(res) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -118,12 +119,12 @@ function psb_samax(x,desc_a, info, jx,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_samax @@ -185,7 +186,8 @@ function psb_samaxv (x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -199,9 +201,9 @@ function psb_samaxv (x,desc_a, info,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -242,12 +244,12 @@ function psb_samaxv (x,desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_samaxv @@ -280,7 +282,8 @@ function psb_samax_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -293,9 +296,9 @@ function psb_samax_vect(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -340,12 +343,12 @@ function psb_samax_vect(x, desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -423,9 +427,9 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -465,12 +469,12 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_samaxvs @@ -532,7 +536,8 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx, i, k integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -545,9 +550,9 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -593,12 +598,12 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_smamaxs @@ -631,7 +636,8 @@ function psb_smin_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -644,9 +650,9 @@ function psb_smin_vect(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -691,12 +697,12 @@ function psb_smin_vect(x, desc_a, info,global) result(res) end if ! compute global min - if (global_) call psb_min(ictxt, res) + if (global_) call psb_min(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_sasum.f90 b/base/psblas/psb_sasum.f90 index a61f1851..6ca62d24 100644 --- a/base/psblas/psb_sasum.f90 +++ b/base/psblas/psb_sasum.f90 @@ -57,7 +57,8 @@ function psb_sasum (x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_sasum (x,desc_a, info, jx,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -125,12 +126,12 @@ function psb_sasum (x,desc_a, info, jx,global) result(res) res = szero end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_sasum @@ -160,7 +161,8 @@ function psb_sasum_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, imax, i, idx, ndm integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -174,9 +176,9 @@ function psb_sasum_vect(x, desc_a, info,global) result(res) call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -230,12 +232,12 @@ function psb_sasum_vect(x, desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -297,7 +299,8 @@ function psb_sasumv(x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -310,9 +313,9 @@ function psb_sasumv(x,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -361,12 +364,12 @@ function psb_sasumv(x,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_sasumv @@ -428,7 +431,8 @@ subroutine psb_sasumvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -441,9 +445,9 @@ subroutine psb_sasumvs(res,x,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -492,12 +496,12 @@ subroutine psb_sasumvs(res,x,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt,res) + if (global_) call psb_sum(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sasumvs diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index b264c3b0..774c1ad7 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -59,7 +59,8 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -69,9 +70,9 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -123,7 +124,7 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -192,7 +193,8 @@ subroutine psb_saxpby_vect_out(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -202,9 +204,9 @@ subroutine psb_saxpby_vect_out(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -269,7 +271,7 @@ subroutine psb_saxpby_vect_out(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -308,7 +310,8 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) real(psb_spk_), intent(inout) :: y(:,:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, in, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -320,8 +323,8 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -390,7 +393,7 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_saxpby @@ -456,7 +459,8 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) real(psb_spk_), intent(inout) :: y(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -469,9 +473,9 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -514,7 +518,7 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_saxpbyv @@ -578,7 +582,8 @@ subroutine psb_saxpbyvout(alpha, x, beta,y, z, desc_a,info) real(psb_spk_), intent(inout) :: z(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -591,9 +596,9 @@ subroutine psb_saxpbyvout(alpha, x, beta,y, z, desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -645,7 +650,7 @@ subroutine psb_saxpbyvout(alpha, x, beta,y, z, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_saxpbyvout @@ -673,7 +678,8 @@ subroutine psb_saddconst_vect(x,b,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -683,9 +689,9 @@ subroutine psb_saddconst_vect(x,b,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -730,7 +736,7 @@ subroutine psb_saddconst_vect(x,b,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_scmp_vect.f90 b/base/psblas/psb_scmp_vect.f90 index c67cda7c..7a7ff002 100644 --- a/base/psblas/psb_scmp_vect.f90 +++ b/base/psblas/psb_scmp_vect.f90 @@ -41,7 +41,8 @@ subroutine psb_scmp_vect(x,c,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -51,9 +52,9 @@ subroutine psb_scmp_vect(x,c,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_scmp_vect(x,c,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -148,7 +149,8 @@ subroutine psb_smask_vect(c,x,m,t,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, mm character(len=20) :: name, ch_err @@ -158,9 +160,9 @@ subroutine psb_smask_vect(c,x,m,t,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -214,12 +216,12 @@ subroutine psb_smask_vect(c,x,m,t,desc_a,info) call m%mask(c,x,t,info) end if - call psb_lallreduceand(ictxt,t) + call psb_lallreduceand(ctxt,t) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -237,7 +239,8 @@ subroutine psb_scmp_spmatval(a,val,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -251,8 +254,8 @@ subroutine psb_scmp_spmatval(a,val,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -266,16 +269,16 @@ subroutine psb_scmp_spmatval(a,val,tol,desc_a,res,info) res = a%spcmp(val,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_scmp_spmatval @@ -291,7 +294,8 @@ subroutine psb_scmp_spmat(a,b,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -305,8 +309,8 @@ subroutine psb_scmp_spmat(a,b,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -322,17 +326,17 @@ subroutine psb_scmp_spmat(a,b,tol,desc_a,res,info) res = a%spcmp(b,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_sdiv_vect.f90 b/base/psblas/psb_sdiv_vect.f90 index 2fba3e73..70bb96d0 100644 --- a/base/psblas/psb_sdiv_vect.f90 +++ b/base/psblas/psb_sdiv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_sdiv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_sdiv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_sdiv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -114,7 +115,8 @@ subroutine psb_sdiv_vect2(x,y,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -124,9 +126,9 @@ subroutine psb_sdiv_vect2(x,y,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -185,7 +187,7 @@ subroutine psb_sdiv_vect2(x,y,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -201,7 +203,8 @@ subroutine psb_sdiv_vect_check(x,y,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -211,9 +214,9 @@ subroutine psb_sdiv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -259,7 +262,7 @@ subroutine psb_sdiv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -276,7 +279,8 @@ subroutine psb_sdiv_vect2_check(x,y,z,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -286,9 +290,9 @@ subroutine psb_sdiv_vect2_check(x,y,z,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -346,7 +350,7 @@ subroutine psb_sdiv_vect2_check(x,y,z,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -369,7 +373,8 @@ function psb_sminquotient_vect(x,y,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -382,9 +387,9 @@ function psb_sminquotient_vect(x,y,desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -429,12 +434,12 @@ function psb_sminquotient_vect(x,y,desc_a,info,global) result(res) end if ! compute global min - if (global_) call psb_min(ictxt, res) + if (global_) call psb_min(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_sdot.f90 b/base/psblas/psb_sdot.f90 index cce9e15c..cf0678a7 100644 --- a/base/psblas/psb_sdot.f90 +++ b/base/psblas/psb_sdot.f90 @@ -64,7 +64,8 @@ function psb_sdot_vect(x, y, desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -78,8 +79,8 @@ function psb_sdot_vect(x, y, desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -146,12 +147,12 @@ function psb_sdot_vect(x, y, desc_a,info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -187,7 +188,8 @@ function psb_sdot(x, y,desc_a, info, jx, jy,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m real(psb_spk_) :: sdot @@ -201,8 +203,8 @@ function psb_sdot(x, y,desc_a, info, jx, jy,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -270,12 +272,12 @@ function psb_sdot(x, y,desc_a, info, jx, jy,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_sdot @@ -338,7 +340,8 @@ function psb_sdotv(x, y,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -352,9 +355,9 @@ function psb_sdotv(x, y,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -405,13 +408,13 @@ function psb_sdotv(x, y,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_sdotv @@ -474,7 +477,8 @@ subroutine psb_sdotvs(res, x, y,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -488,9 +492,9 @@ subroutine psb_sdotvs(res, x, y,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -539,12 +543,12 @@ subroutine psb_sdotvs(res, x, y,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sdotvs @@ -608,7 +612,8 @@ subroutine psb_smdots(res, x, y, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -622,9 +627,9 @@ subroutine psb_smdots(res, x, y, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -685,12 +690,12 @@ subroutine psb_smdots(res, x, y, desc_a, info,global) ! compute global sum - if (global_) call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_smdots diff --git a/base/psblas/psb_sgetmatinfo.f90 b/base/psblas/psb_sgetmatinfo.F90 similarity index 90% rename from base/psblas/psb_sgetmatinfo.f90 rename to base/psblas/psb_sgetmatinfo.F90 index 8888d4db..abf1210c 100644 --- a/base/psblas/psb_sgetmatinfo.f90 +++ b/base/psblas/psb_sgetmatinfo.F90 @@ -37,9 +37,13 @@ function psb_sget_nnz(a,desc_a,info) result(res) use psb_base_mod, psb_protect_name => psb_sget_nnz use psi_mod - use mpi - - implicit none +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif integer(psb_lpk_) :: res type(psb_sspmat_type), intent(in) :: a @@ -47,7 +51,8 @@ function psb_sget_nnz(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja integer(psb_lpk_) :: localnnz character(len=20) :: name, ch_err @@ -59,8 +64,8 @@ function psb_sget_nnz(a,desc_a,info) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -69,12 +74,12 @@ function psb_sget_nnz(a,desc_a,info) result(res) localnnz = a%get_nzeros() - call psb_sum(ictxt,localnnz) + call psb_sum(ctxt,localnnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function diff --git a/base/psblas/psb_sinv_vect.f90 b/base/psblas/psb_sinv_vect.f90 index 5666a821..f658b177 100644 --- a/base/psblas/psb_sinv_vect.f90 +++ b/base/psblas/psb_sinv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_sinv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_sinv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_sinv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -115,7 +116,8 @@ subroutine psb_sinv_vect_check(x,y,desc_a,info,flag) logical :: check ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -125,9 +127,9 @@ subroutine psb_sinv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -176,7 +178,7 @@ subroutine psb_sinv_vect_check(x,y,desc_a,info,flag) check = .TRUE. end if - call psb_lallreduceand(ictxt,check) + call psb_lallreduceand(ctxt,check) if (check) then info = 1_psb_ipk_ @@ -187,7 +189,7 @@ subroutine psb_sinv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_smlt_vect.f90 b/base/psblas/psb_smlt_vect.f90 index 8f1623d9..04b3150c 100644 --- a/base/psblas/psb_smlt_vect.f90 +++ b/base/psblas/psb_smlt_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_smlt_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_smlt_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_smlt_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -120,7 +121,8 @@ subroutine psb_smlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) character(len=1), intent(in), optional :: conjgx, conjgy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -130,9 +132,9 @@ subroutine psb_smlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -191,7 +193,7 @@ subroutine psb_smlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index ab9c56ca..2211224b 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -60,7 +60,8 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -74,9 +75,9 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -126,12 +127,12 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_snrm2 @@ -195,7 +196,8 @@ function psb_snrm2v(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_spk_) :: snrm2, dd @@ -209,9 +211,9 @@ function psb_snrm2v(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -254,12 +256,12 @@ function psb_snrm2v(x, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_snrm2v @@ -291,7 +293,8 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -305,9 +308,9 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -360,12 +363,12 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_snrm2_vect @@ -398,7 +401,8 @@ function psb_snrm2_weight_vect(x,w, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -412,9 +416,9 @@ function psb_snrm2_weight_vect(x,w, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -467,12 +471,12 @@ function psb_snrm2_weight_vect(x,w, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_snrm2_weight_vect @@ -508,7 +512,8 @@ function psb_snrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -522,9 +527,9 @@ function psb_snrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -577,12 +582,12 @@ function psb_snrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_snrm2_weightmask_vect @@ -645,7 +650,8 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -659,9 +665,9 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -706,13 +712,13 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) res = szero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_snrm2vs diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 index 9fc41073..d48bb5f9 100644 --- a/base/psblas/psb_snrmi.f90 +++ b/base/psblas/psb_snrmi.f90 @@ -53,7 +53,8 @@ function psb_snrmi(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: m, n, ia, ja logical :: global_ @@ -66,9 +67,9 @@ function psb_snrmi(a,desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -113,12 +114,12 @@ function psb_snrmi(a,desc_a,info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_snrmi diff --git a/base/psblas/psb_sspmm.f90 b/base/psblas/psb_sspmm.f90 index 56b881b8..43ee0d48 100644 --- a/base/psblas/psb_sspmm.f90 +++ b/base/psblas/psb_sspmm.f90 @@ -71,7 +71,8 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja @@ -92,8 +93,8 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -250,12 +251,12 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sspmv_vect @@ -309,7 +310,8 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik @@ -330,9 +332,9 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -581,7 +583,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sspmm @@ -656,7 +658,8 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -677,8 +680,8 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -886,12 +889,12 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sspmv diff --git a/base/psblas/psb_sspnrm1.f90 b/base/psblas/psb_sspnrm1.f90 index 9d2afeb8..09ea96fb 100644 --- a/base/psblas/psb_sspnrm1.f90 +++ b/base/psblas/psb_sspnrm1.f90 @@ -53,7 +53,8 @@ function psb_sspnrm1(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, nr,nc,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, nr,nc,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ @@ -65,9 +66,9 @@ function psb_sspnrm1(a,desc_a,info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -129,12 +130,12 @@ function psb_sspnrm1(a,desc_a,info,global) result(res) res = szero end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_sspnrm1 diff --git a/base/psblas/psb_sspsm.f90 b/base/psblas/psb_sspsm.f90 index 1cbbd6d2..522d4bd9 100644 --- a/base/psblas/psb_sspsm.f90 +++ b/base/psblas/psb_sspsm.f90 @@ -84,7 +84,8 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -103,9 +104,9 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -223,7 +224,7 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sspsv_vect @@ -289,7 +290,8 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: k, jx, jy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -308,9 +310,9 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -476,7 +478,7 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sspsm @@ -533,7 +535,8 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -552,9 +555,9 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -705,7 +708,7 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_sspsv diff --git a/base/psblas/psb_svmlt.f90 b/base/psblas/psb_svmlt.f90 index cfe09de1..a9b506c6 100644 --- a/base/psblas/psb_svmlt.f90 +++ b/base/psblas/psb_svmlt.f90 @@ -40,7 +40,7 @@ subroutine psb_svmlt(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + integer(psb_ipk_) :: ctxt, np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +50,9 @@ subroutine psb_svmlt(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -104,7 +104,7 @@ subroutine psb_svmlt(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_zabs_vect.f90 b/base/psblas/psb_zabs_vect.f90 index 86ac6bfb..8c027727 100644 --- a/base/psblas/psb_zabs_vect.f90 +++ b/base/psblas/psb_zabs_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_zabs_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_zabs_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_zabs_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index 8fd10043..79cc6d96 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -57,7 +57,8 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -118,12 +119,12 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_zamax @@ -185,7 +186,8 @@ function psb_zamaxv (x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -199,9 +201,9 @@ function psb_zamaxv (x,desc_a, info,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -242,12 +244,12 @@ function psb_zamaxv (x,desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_zamaxv @@ -280,7 +282,8 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -293,9 +296,9 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -340,12 +343,12 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -423,9 +427,9 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -465,12 +469,12 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zamaxvs @@ -532,7 +536,8 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ldx, i, k integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -545,9 +550,9 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -593,12 +598,12 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx,global) end if ! compute global max - if (global_) call psb_amx(ictxt, res(1:k)) + if (global_) call psb_amx(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zmamaxs diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index 9b6fddd7..63061d0b 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -57,7 +57,8 @@ function psb_zasum (x,desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -71,9 +72,9 @@ function psb_zasum (x,desc_a, info, jx,global) result(res) end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -125,12 +126,12 @@ function psb_zasum (x,desc_a, info, jx,global) result(res) res = dzero end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_zasum @@ -160,7 +161,8 @@ function psb_zasum_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, imax, i, idx, ndm integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -174,9 +176,9 @@ function psb_zasum_vect(x, desc_a, info,global) result(res) call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -230,12 +232,12 @@ function psb_zasum_vect(x, desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -297,7 +299,8 @@ function psb_zasumv(x,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -310,9 +313,9 @@ function psb_zasumv(x,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -361,12 +364,12 @@ function psb_zasumv(x,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_zasumv @@ -428,7 +431,8 @@ subroutine psb_zasumvs(res,x,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, i, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -441,9 +445,9 @@ subroutine psb_zasumvs(res,x,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -492,12 +496,12 @@ subroutine psb_zasumvs(res,x,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt,res) + if (global_) call psb_sum(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zasumvs diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index c0cf79fd..1165ea8a 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -59,7 +59,8 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -69,9 +70,9 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -123,7 +124,7 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -192,7 +193,8 @@ subroutine psb_zaxpby_vect_out(alpha, x, beta, y,& integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -202,9 +204,9 @@ subroutine psb_zaxpby_vect_out(alpha, x, beta, y,& info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -269,7 +271,7 @@ subroutine psb_zaxpby_vect_out(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -308,7 +310,8 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) complex(psb_dpk_), intent(inout) :: y(:,:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, in, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -320,8 +323,8 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -390,7 +393,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zaxpby @@ -456,7 +459,8 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) complex(psb_dpk_), intent(inout) :: y(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -469,9 +473,9 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -514,7 +518,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zaxpbyv @@ -578,7 +582,8 @@ subroutine psb_zaxpbyvout(alpha, x, beta,y, z, desc_a,info) complex(psb_dpk_), intent(inout) :: z(:) ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -591,9 +596,9 @@ subroutine psb_zaxpbyvout(alpha, x, beta,y, z, desc_a,info) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -645,7 +650,7 @@ subroutine psb_zaxpbyvout(alpha, x, beta,y, z, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zaxpbyvout @@ -673,7 +678,8 @@ subroutine psb_zaddconst_vect(x,b,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -683,9 +689,9 @@ subroutine psb_zaddconst_vect(x,b,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -730,7 +736,7 @@ subroutine psb_zaddconst_vect(x,b,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_zcmp_vect.f90 b/base/psblas/psb_zcmp_vect.f90 index d0184d09..01e1cecf 100644 --- a/base/psblas/psb_zcmp_vect.f90 +++ b/base/psblas/psb_zcmp_vect.f90 @@ -41,7 +41,8 @@ subroutine psb_zcmp_vect(x,c,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -51,9 +52,9 @@ subroutine psb_zcmp_vect(x,c,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_zcmp_vect(x,c,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -115,7 +116,8 @@ subroutine psb_zcmp_spmatval(a,val,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -129,8 +131,8 @@ subroutine psb_zcmp_spmatval(a,val,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -144,16 +146,16 @@ subroutine psb_zcmp_spmatval(a,val,tol,desc_a,res,info) res = a%spcmp(val,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zcmp_spmatval @@ -169,7 +171,8 @@ subroutine psb_zcmp_spmat(a,b,tol,desc_a,res,info) logical, intent(out) :: res ! Local - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: err_act character(len=20) :: name, ch_err integer(psb_ipk_) :: debug_level, debug_unit @@ -183,8 +186,8 @@ subroutine psb_zcmp_spmat(a,b,tol,desc_a,res,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -200,17 +203,17 @@ subroutine psb_zcmp_spmat(a,b,tol,desc_a,res,info) res = a%spcmp(b,tol,info) end if - call psb_lallreduceand(ictxt,res) + call psb_lallreduceand(ctxt,res) call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_zdiv_vect.f90 b/base/psblas/psb_zdiv_vect.f90 index f07f5d00..22d8b21c 100644 --- a/base/psblas/psb_zdiv_vect.f90 +++ b/base/psblas/psb_zdiv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_zdiv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_zdiv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_zdiv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -114,7 +115,8 @@ subroutine psb_zdiv_vect2(x,y,z,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -124,9 +126,9 @@ subroutine psb_zdiv_vect2(x,y,z,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -185,7 +187,7 @@ subroutine psb_zdiv_vect2(x,y,z,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -201,7 +203,8 @@ subroutine psb_zdiv_vect_check(x,y,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -211,9 +214,9 @@ subroutine psb_zdiv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -259,7 +262,7 @@ subroutine psb_zdiv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -276,7 +279,8 @@ subroutine psb_zdiv_vect2_check(x,y,z,desc_a,info,flag) logical, intent(in) :: flag ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -286,9 +290,9 @@ subroutine psb_zdiv_vect2_check(x,y,z,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -346,7 +350,7 @@ subroutine psb_zdiv_vect2_check(x,y,z,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index ad21b1d8..97ecbedf 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -64,7 +64,8 @@ function psb_zdot_vect(x, y, desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -78,8 +79,8 @@ function psb_zdot_vect(x, y, desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -146,12 +147,12 @@ function psb_zdot_vect(x, y, desc_a,info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -187,7 +188,8 @@ function psb_zdot(x, y,desc_a, info, jx, jy,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m complex(psb_dpk_) :: zdotc @@ -201,8 +203,8 @@ function psb_zdot(x, y,desc_a, info, jx, jy,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -270,12 +272,12 @@ function psb_zdot(x, y,desc_a, info, jx, jy,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_zdot @@ -338,7 +340,8 @@ function psb_zdotv(x, y,desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -352,9 +355,9 @@ function psb_zdotv(x, y,desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -405,13 +408,13 @@ function psb_zdotv(x, y,desc_a, info,global) result(res) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_zdotv @@ -474,7 +477,8 @@ subroutine psb_zdotvs(res, x, y,desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ @@ -488,9 +492,9 @@ subroutine psb_zdotvs(res, x, y,desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -539,12 +543,12 @@ subroutine psb_zdotvs(res, x, y,desc_a, info,global) end if ! compute global sum - if (global_) call psb_sum(ictxt, res) + if (global_) call psb_sum(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zdotvs @@ -608,7 +612,8 @@ subroutine psb_zmdots(res, x, y, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, idx, ndm,& & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -622,9 +627,9 @@ subroutine psb_zmdots(res, x, y, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -685,12 +690,12 @@ subroutine psb_zmdots(res, x, y, desc_a, info,global) ! compute global sum - if (global_) call psb_sum(ictxt, res(1:k)) + if (global_) call psb_sum(ctxt, res(1:k)) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zmdots diff --git a/base/psblas/psb_zgetmatinfo.f90 b/base/psblas/psb_zgetmatinfo.F90 similarity index 90% rename from base/psblas/psb_zgetmatinfo.f90 rename to base/psblas/psb_zgetmatinfo.F90 index 7d18418b..fab395f2 100644 --- a/base/psblas/psb_zgetmatinfo.f90 +++ b/base/psblas/psb_zgetmatinfo.F90 @@ -37,9 +37,13 @@ function psb_zget_nnz(a,desc_a,info) result(res) use psb_base_mod, psb_protect_name => psb_zget_nnz use psi_mod - use mpi - - implicit none +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif integer(psb_lpk_) :: res type(psb_zspmat_type), intent(in) :: a @@ -47,7 +51,8 @@ function psb_zget_nnz(a,desc_a,info) result(res) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja integer(psb_lpk_) :: localnnz character(len=20) :: name, ch_err @@ -59,8 +64,8 @@ function psb_zget_nnz(a,desc_a,info) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -69,12 +74,12 @@ function psb_zget_nnz(a,desc_a,info) result(res) localnnz = a%get_nzeros() - call psb_sum(ictxt,localnnz) + call psb_sum(ctxt,localnnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function diff --git a/base/psblas/psb_zinv_vect.f90 b/base/psblas/psb_zinv_vect.f90 index bb37ee69..593d342b 100644 --- a/base/psblas/psb_zinv_vect.f90 +++ b/base/psblas/psb_zinv_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_zinv_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_zinv_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_zinv_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -115,7 +116,8 @@ subroutine psb_zinv_vect_check(x,y,desc_a,info,flag) logical :: check ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -125,9 +127,9 @@ subroutine psb_zinv_vect_check(x,y,desc_a,info,flag) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -176,7 +178,7 @@ subroutine psb_zinv_vect_check(x,y,desc_a,info,flag) check = .TRUE. end if - call psb_lallreduceand(ictxt,check) + call psb_lallreduceand(ctxt,check) if (check) then info = 1_psb_ipk_ @@ -187,7 +189,7 @@ subroutine psb_zinv_vect_check(x,y,desc_a,info,flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_zmlt_vect.f90 b/base/psblas/psb_zmlt_vect.f90 index 598a12a7..5db9cdb4 100644 --- a/base/psblas/psb_zmlt_vect.f90 +++ b/base/psblas/psb_zmlt_vect.f90 @@ -40,7 +40,8 @@ subroutine psb_zmlt_vect(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +51,9 @@ subroutine psb_zmlt_vect(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -98,7 +99,7 @@ subroutine psb_zmlt_vect(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -120,7 +121,8 @@ subroutine psb_zmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) character(len=1), intent(in), optional :: conjgx, conjgy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iiy, jjy, iiz, jjz integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m character(len=20) :: name, ch_err @@ -130,9 +132,9 @@ subroutine psb_zmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -191,7 +193,7 @@ subroutine psb_zmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index bfa29d18..1ba0f9da 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -60,7 +60,8 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ @@ -74,9 +75,9 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -126,12 +127,12 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_znrm2 @@ -195,7 +196,8 @@ function psb_znrm2v(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_dpk_) :: dznrm2, dd @@ -209,9 +211,9 @@ function psb_znrm2v(x, desc_a, info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -254,12 +256,12 @@ function psb_znrm2v(x, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_znrm2v @@ -291,7 +293,8 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -305,9 +308,9 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -360,12 +363,12 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_znrm2_vect @@ -398,7 +401,8 @@ function psb_znrm2_weight_vect(x,w, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -412,9 +416,9 @@ function psb_znrm2_weight_vect(x,w, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -467,12 +471,12 @@ function psb_znrm2_weight_vect(x,w, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_znrm2_weight_vect @@ -508,7 +512,8 @@ function psb_znrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -522,9 +527,9 @@ function psb_znrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -577,12 +582,12 @@ function psb_znrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_znrm2_weightmask_vect @@ -645,7 +650,8 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ @@ -659,9 +665,9 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -706,13 +712,13 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) res = dzero end if - if (global_) call psb_nrm2(ictxt,res) + if (global_) call psb_nrm2(ctxt,res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_znrm2vs diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index 19b071e4..9afae6e7 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -53,7 +53,8 @@ function psb_znrmi(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: m, n, ia, ja logical :: global_ @@ -66,9 +67,9 @@ function psb_znrmi(a,desc_a,info,global) result(res) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -113,12 +114,12 @@ function psb_znrmi(a,desc_a,info,global) result(res) end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_znrmi diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index add3205b..b58ca303 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -71,7 +71,8 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja @@ -92,8 +93,8 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -250,12 +251,12 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zspmv_vect @@ -309,7 +310,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik @@ -330,9 +332,9 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -581,7 +583,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zspmm @@ -656,7 +658,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& logical, intent(in), optional :: doswap ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & & liwork, iiy, jjy, ib, ip, idx, ik integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -677,8 +680,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt=desc_a%get_context() + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -886,12 +889,12 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) if (debug_level >= psb_debug_comp_) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) write(debug_unit,*) me,' ',trim(name),' Returning ' endif return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zspmv diff --git a/base/psblas/psb_zspnrm1.f90 b/base/psblas/psb_zspnrm1.f90 index 7bc5fa15..cb568ab8 100644 --- a/base/psblas/psb_zspnrm1.f90 +++ b/base/psblas/psb_zspnrm1.f90 @@ -53,7 +53,8 @@ function psb_zspnrm1(a,desc_a,info,global) result(res) logical, intent(in), optional :: global ! locals - integer(psb_ipk_) :: ictxt, np, me, nr,nc,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, nr,nc,& & err_act, iia, jja, mdim, ndim integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ @@ -65,9 +66,9 @@ function psb_zspnrm1(a,desc_a,info,global) result(res) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -129,12 +130,12 @@ function psb_zspnrm1(a,desc_a,info,global) result(res) res = dzero end if ! compute global max - if (global_) call psb_amx(ictxt, res) + if (global_) call psb_amx(ctxt, res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end function psb_zspnrm1 diff --git a/base/psblas/psb_zspsm.f90 b/base/psblas/psb_zspsm.f90 index 63cbe783..80fbfb56 100644 --- a/base/psblas/psb_zspsm.f90 +++ b/base/psblas/psb_zspsm.f90 @@ -84,7 +84,8 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -103,9 +104,9 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -223,7 +224,7 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zspsv_vect @@ -289,7 +290,8 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: k, jx, jy ! locals - integer(psb_ipk_) :: ictxt, np, me,& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm @@ -308,9 +310,9 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -476,7 +478,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zspsm @@ -533,7 +535,8 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), intent(in), optional :: choice ! locals - integer(psb_ipk_) :: ictxt, np, me, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy @@ -552,9 +555,9 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -705,7 +708,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_zspsv diff --git a/base/psblas/psb_zvmlt.f90 b/base/psblas/psb_zvmlt.f90 index 01a6fc68..a4c06fc4 100644 --- a/base/psblas/psb_zvmlt.f90 +++ b/base/psblas/psb_zvmlt.f90 @@ -40,7 +40,7 @@ subroutine psb_zvmlt(x,y,desc_a,info) integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_ipk_) :: ictxt, np, me,& + integer(psb_ipk_) :: ctxt, np, me,& & err_act, iix, jjx, iiy, jjy integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err @@ -50,9 +50,9 @@ subroutine psb_zvmlt(x,y,desc_a,info) info=psb_success_ call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -ione) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -104,7 +104,7 @@ subroutine psb_zvmlt(x,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 69c67d02..cc112015 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -582,7 +582,7 @@ end subroutine psb_c_get_neigh -subroutine psb_c_csall(nr,nc,a,info,nz) +subroutine psb_c_csall(nr,nc,a,info,nz,type,mold) use psb_c_mat_mod, psb_protect_name => psb_c_csall use psb_c_base_mat_mod use psb_error_mod @@ -591,6 +591,8 @@ subroutine psb_c_csall(nr,nc,a,info,nz) integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_c_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -601,7 +603,23 @@ subroutine psb_c_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_c_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_c_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_c_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_c_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_c_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_c_coo_sparse_mat :: a%a, stat=info) + end if + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) @@ -3381,7 +3399,7 @@ end subroutine psb_lc_get_neigh -subroutine psb_lc_csall(nr,nc,a,info,nz) +subroutine psb_lc_csall(nr,nc,a,info,nz,type,mold) use psb_c_mat_mod, psb_protect_name => psb_lc_csall use psb_c_base_mat_mod use psb_error_mod @@ -3390,6 +3408,8 @@ subroutine psb_lc_csall(nr,nc,a,info,nz) integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_lc_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -3400,7 +3420,22 @@ subroutine psb_lc_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_lc_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_lc_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_lc_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_lc_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_lc_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_lc_coo_sparse_mat :: a%a, stat=info) + end if if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 86de5536..7f4ac0c1 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -582,7 +582,7 @@ end subroutine psb_d_get_neigh -subroutine psb_d_csall(nr,nc,a,info,nz) +subroutine psb_d_csall(nr,nc,a,info,nz,type,mold) use psb_d_mat_mod, psb_protect_name => psb_d_csall use psb_d_base_mat_mod use psb_error_mod @@ -591,6 +591,8 @@ subroutine psb_d_csall(nr,nc,a,info,nz) integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_d_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -601,7 +603,23 @@ subroutine psb_d_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_d_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_d_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_d_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_d_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_d_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_d_coo_sparse_mat :: a%a, stat=info) + end if + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) @@ -3381,7 +3399,7 @@ end subroutine psb_ld_get_neigh -subroutine psb_ld_csall(nr,nc,a,info,nz) +subroutine psb_ld_csall(nr,nc,a,info,nz,type,mold) use psb_d_mat_mod, psb_protect_name => psb_ld_csall use psb_d_base_mat_mod use psb_error_mod @@ -3390,6 +3408,8 @@ subroutine psb_ld_csall(nr,nc,a,info,nz) integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_ld_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -3400,7 +3420,22 @@ subroutine psb_ld_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_ld_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_ld_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_ld_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_ld_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_ld_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_ld_coo_sparse_mat :: a%a, stat=info) + end if if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 867f9fa4..806a08e3 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -582,7 +582,7 @@ end subroutine psb_s_get_neigh -subroutine psb_s_csall(nr,nc,a,info,nz) +subroutine psb_s_csall(nr,nc,a,info,nz,type,mold) use psb_s_mat_mod, psb_protect_name => psb_s_csall use psb_s_base_mat_mod use psb_error_mod @@ -591,6 +591,8 @@ subroutine psb_s_csall(nr,nc,a,info,nz) integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_s_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -601,7 +603,23 @@ subroutine psb_s_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_s_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_s_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_s_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_s_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_s_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_s_coo_sparse_mat :: a%a, stat=info) + end if + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) @@ -3381,7 +3399,7 @@ end subroutine psb_ls_get_neigh -subroutine psb_ls_csall(nr,nc,a,info,nz) +subroutine psb_ls_csall(nr,nc,a,info,nz,type,mold) use psb_s_mat_mod, psb_protect_name => psb_ls_csall use psb_s_base_mat_mod use psb_error_mod @@ -3390,6 +3408,8 @@ subroutine psb_ls_csall(nr,nc,a,info,nz) integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_ls_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -3400,7 +3420,22 @@ subroutine psb_ls_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_ls_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_ls_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_ls_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_ls_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_ls_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_ls_coo_sparse_mat :: a%a, stat=info) + end if if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index 07616c05..422a664d 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -582,7 +582,7 @@ end subroutine psb_z_get_neigh -subroutine psb_z_csall(nr,nc,a,info,nz) +subroutine psb_z_csall(nr,nc,a,info,nz,type,mold) use psb_z_mat_mod, psb_protect_name => psb_z_csall use psb_z_base_mat_mod use psb_error_mod @@ -591,6 +591,8 @@ subroutine psb_z_csall(nr,nc,a,info,nz) integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_z_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -601,7 +603,23 @@ subroutine psb_z_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_z_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_z_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_z_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_z_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_z_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_z_coo_sparse_mat :: a%a, stat=info) + end if + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) @@ -3381,7 +3399,7 @@ end subroutine psb_lz_get_neigh -subroutine psb_lz_csall(nr,nc,a,info,nz) +subroutine psb_lz_csall(nr,nc,a,info,nz,type,mold) use psb_z_mat_mod, psb_protect_name => psb_lz_csall use psb_z_base_mat_mod use psb_error_mod @@ -3390,6 +3408,8 @@ subroutine psb_lz_csall(nr,nc,a,info,nz) integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz + character(len=*), intent(in), optional :: type + class(psb_lz_base_sparse_mat), optional, intent(in) :: mold integer(psb_ipk_) :: err_act character(len=20) :: name='csall' @@ -3400,7 +3420,22 @@ subroutine psb_lz_csall(nr,nc,a,info,nz) call a%free() info = psb_success_ - allocate(psb_lz_coo_sparse_mat :: a%a, stat=info) + if (present(mold)) then + allocate(a%a, stat=info, mold=mold) + else if (present(type)) then + select case (type) + case('CSR') + allocate(psb_lz_csr_sparse_mat :: a%a, stat=info) + case('COO') + allocate(psb_lz_coo_sparse_mat :: a%a, stat=info) + case('CSC') + allocate(psb_lz_csc_sparse_mat :: a%a, stat=info) + case default + allocate(psb_lz_coo_sparse_mat :: a%a, stat=info) + end select + else + allocate(psb_lz_coo_sparse_mat :: a%a, stat=info) + end if if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) diff --git a/base/serial/psb_dgelp.f90 b/base/serial/psb_dgelp.f90 index 7dc4b132..40ade223 100644 --- a/base/serial/psb_dgelp.f90 +++ b/base/serial/psb_dgelp.f90 @@ -54,7 +54,7 @@ subroutine psb_dgelp(trans,iperm,x,info) ! local variables real(psb_dpk_),allocatable :: temp(:) integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j - integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_ipk_), allocatable :: itemp(:) real(psb_dpk_),parameter :: one=1 integer(psb_ipk_) :: debug_level, debug_unit @@ -180,7 +180,7 @@ subroutine psb_dgelpv(trans,iperm,x,info) ! local variables integer(psb_ipk_) :: int_err(5), i1sz, err_act, i real(psb_dpk_),allocatable :: temp(:) - integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_ipk_), allocatable :: itemp(:) real(psb_dpk_),parameter :: one=1 integer(psb_ipk_) :: debug_level, debug_unit diff --git a/base/serial/psb_sgelp.f90 b/base/serial/psb_sgelp.f90 index 6cb6f6f1..9b7a2f64 100644 --- a/base/serial/psb_sgelp.f90 +++ b/base/serial/psb_sgelp.f90 @@ -50,11 +50,11 @@ subroutine psb_sgelp(trans,iperm,x,info) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans + ! local variables - integer(psb_ipk_) :: ictxt real(psb_spk_),allocatable :: temp(:) integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j - integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_ipk_), allocatable :: itemp(:) real(psb_spk_),parameter :: one=1 integer(psb_ipk_) :: debug_level, debug_unit @@ -178,11 +178,10 @@ subroutine psb_sgelpv(trans,iperm,x,info) character, intent(in) :: trans ! local variables - integer(psb_ipk_) :: ictxt integer(psb_ipk_) :: int_err(5), i1sz, err_act, i - real(psb_spk_),allocatable :: temp(:) - integer(psb_ipk_), allocatable :: itemp(:) - real(psb_spk_),parameter :: one=1 + real(psb_spk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + real(psb_spk_),parameter :: one=1 integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -205,7 +204,7 @@ subroutine psb_sgelpv(trans,iperm,x,info) goto 9999 end if itemp(:) = iperm(:) - + if (.not.psb_isaperm(i1sz,itemp)) then info=psb_err_iarg_invalid_value_ int_err(1) = 1 diff --git a/base/tools/Makefile b/base/tools/Makefile index c8b488d3..1227da3f 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -27,7 +27,8 @@ FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt psb_s_map.o psb_d_map.o psb_c_map.o psb_z_map.o \ psb_s_par_csr_spspmm.o psb_d_par_csr_spspmm.o psb_c_par_csr_spspmm.o psb_z_par_csr_spspmm.o \ psb_s_glob_transpose.o psb_d_glob_transpose.o psb_c_glob_transpose.o psb_z_glob_transpose.o \ - psb_cgetelem.o psb_dgetelem.o psb_sgetelem.o psb_zgetelem.o + psb_cgetelem.o psb_dgetelem.o psb_sgetelem.o psb_zgetelem.o \ + psb_c_remap.o psb_s_remap.o psb_d_remap.o psb_z_remap.o # psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \ MPFOBJS = psb_icdasb.o psb_ssphalo.o psb_dsphalo.o psb_csphalo.o psb_zsphalo.o \ diff --git a/base/tools/psb_c_glob_transpose.F90 b/base/tools/psb_c_glob_transpose.F90 index 1509cf33..4f6804fc 100644 --- a/base/tools/psb_c_glob_transpose.F90 +++ b/base/tools/psb_c_glob_transpose.F90 @@ -110,7 +110,8 @@ subroutine psb_lc_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) integer(psb_ipk_), intent(out) :: info ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_lpk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzt, nzd @@ -137,10 +138,10 @@ subroutine psb_lc_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -287,14 +288,14 @@ subroutine psb_lc_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),acoo%ia(nzl+1:nzl+iszr),& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& @@ -385,7 +386,7 @@ subroutine psb_lc_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_lc_coo_glob_transpose @@ -406,7 +407,8 @@ subroutine psb_c_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) type(psb_desc_type), intent(out), optional :: desc_rx integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_ipk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzd @@ -434,10 +436,10 @@ subroutine psb_c_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -586,14 +588,14 @@ subroutine psb_c_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),iarcv(1:iszr),& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv(1:iszr),rvsz,brvindx,ictxt,info) + & iarcv(1:iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& @@ -690,7 +692,7 @@ subroutine psb_c_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_c_coo_glob_transpose @@ -709,19 +711,20 @@ subroutine psb_c_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_c_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -760,19 +763,20 @@ subroutine psb_c_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_c_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -811,19 +815,20 @@ subroutine psb_lc_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_lc_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -862,19 +867,20 @@ subroutine psb_lc_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_lc_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if diff --git a/base/tools/psb_c_map.f90 b/base/tools/psb_c_map.f90 index 83a54d32..2761205d 100644 --- a/base/tools/psb_c_map.f90 +++ b/base/tools/psb_c_map.f90 @@ -51,7 +51,8 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work) ! complex(psb_spk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V' info = psb_success_ @@ -66,14 +67,14 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() + ctxt = map%p_desc_V%get_context() nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,x,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info) if (info /= psb_success_) then @@ -83,7 +84,7 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() + ctxt = map%desc_V%get_context() nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -93,7 +94,7 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,xt,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info) if (info /= psb_success_) then @@ -125,7 +126,8 @@ subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_c_vect_type),pointer :: ptx, pty complex(psb_spk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V_v' info = psb_success_ @@ -140,8 +142,8 @@ subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_V%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() if (present(vty)) then @@ -154,7 +156,7 @@ subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,x,czero,pty,info) if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info) @@ -167,8 +169,8 @@ subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_V%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -188,7 +190,7 @@ subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,ptx,czero,pty,info) if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info) @@ -232,7 +234,8 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work) ! complex(psb_spk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U' info = psb_success_ @@ -247,14 +250,14 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() + ctxt = map%p_desc_U%get_context() nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,x,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_U,info) if (info /= psb_success_) then @@ -264,7 +267,7 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() + ctxt = map%desc_U%get_context() nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -274,7 +277,7 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,xt,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_U,info) if (info /= psb_success_) then @@ -305,7 +308,8 @@ subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_c_vect_type),pointer :: ptx, pty complex(psb_spk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U_v' info = psb_success_ @@ -320,8 +324,8 @@ subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_U%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() if (present(vty)) then @@ -334,7 +338,7 @@ subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,x,czero,pty,info) if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info) @@ -347,8 +351,8 @@ subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_U%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -369,7 +373,7 @@ subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,ptx,czero,pty,info) if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info) diff --git a/base/tools/psb_c_par_csr_spspmm.f90 b/base/tools/psb_c_par_csr_spspmm.f90 index 058d1a62..d5684b11 100644 --- a/base/tools/psb_c_par_csr_spspmm.f90 +++ b/base/tools/psb_c_par_csr_spspmm.f90 @@ -73,7 +73,8 @@ Subroutine psb_c_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: ncol, nnz type(psb_lc_csr_sparse_mat) :: ltcsr type(psb_c_csr_sparse_mat) :: tcsr @@ -91,9 +92,9 @@ Subroutine psb_c_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -150,7 +151,7 @@ Subroutine psb_c_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -168,7 +169,8 @@ Subroutine psb_lc_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_lpk_) :: nacol, nccol, nnz type(psb_lc_csr_sparse_mat) :: tcsr1 logical :: update_desc_c @@ -185,9 +187,9 @@ Subroutine psb_lc_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -244,7 +246,7 @@ Subroutine psb_lc_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_c_remap.F90 b/base/tools/psb_c_remap.F90 new file mode 100644 index 00000000..881b2ad0 --- /dev/null +++ b/base/tools/psb_c_remap.F90 @@ -0,0 +1,255 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! +! +! Subroutine: psb_c_remap +! +! Arguments: +! desc_in - type(psb_desc_type). The communication descriptor to be cloned. +! desc_out - type(psb_desc_type). The output communication descriptor. +! info - integer. Return code. +subroutine psb_c_remap(np_remap, desc_in, a_in, ipd, isrc, nrsrc, naggr, & + & desc_out, a_out, info) + + use psb_base_mod, psb_protect_name => psb_c_remap + + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_cspmat_type), intent(inout) :: a_in + type(psb_cspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + + + ! locals + type(psb_ctxt_type) :: ctxt, newctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_) :: rnp, rme + integer(psb_ipk_) :: ipdest, id1, id2, imd, i, nsrc + integer(psb_ipk_), allocatable :: newnl(:), nzsrc(:), ids(:) + type(psb_lc_coo_sparse_mat) :: acoo_snd, acoo_rcv + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cdcpy' + + ctxt = desc_in%get_context() + + ! check on blacs grid + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Entered' + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + +!!$ write(0,*) ' Remapping from ',np,' onto ', np_remap + + if (desc_in%get_fmt() == 'BLOCK') then + ! + ! Should we spread the processes in the new context, + ! or should we keep them close? + ! + if (.true.) then + allocate(ids(0:np_remap-1)) + if (np_remap <= np/2) then + ids(0) = 0 + do ipdest=1,np_remap -1 + ids(ipdest) = ids(ipdest-1) + np/np_remap + end do +!!$ write(0,*) ' IDS ',ids(:) + else + do ipdest = 0, np_remap-1 + ids(ipdest) = ipdest + end do + end if + call psb_init(newctxt,np=np_remap,basectxt=ctxt,ids=ids) + else + call psb_init(newctxt,np=np_remap,basectxt=ctxt) + end if + + call psb_info(newctxt,rme,rnp) +!!$ write(0,*) 'Old context: ',me,np,' New context: ',rme,rnp + call psb_bcast(ctxt,rnp) + allocate(newnl(rnp),naggr(np),stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (rnp >= np) then + write(0,*) ' No remapping on larger proc count now' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + naggr = 0 + + ! + ! Compute destination for my data. + ! Simplistic reallocation: divide the NP processes + ! across the new ones (as balanced as possible), + ! then send all data from old to new process + ! + id2 = np/rnp + id1 = id2+1 + imd = mod(np,rnp) + if (me < (imd*id1)) then + ipdest = (me/id1) + else + ipdest = ( ((me-imd*id1)/id2) + imd) + end if + if (allocated(ids)) then + ipd = ids(ipdest) + else + ipd = ipdest + end if +!!$ write(0,*) ' Sending my data from ',me,' to ', & +!!$ & ipd, 'out of ',rnp,rnp-1 + + ! + ! Compute local rows for all new + ! processes; will have a BLOCK distribution + ! + newnl = 0 + newnl(ipdest+1) = desc_in%get_local_rows() + call psb_sum(ctxt,newnl) + + if (rme>=0) then + ! + if (rme < imd) then + isrc = [ (i, i=rme*id1,min(rme*id1+id1-1,np-1)) ] + else + isrc = [ (i, i= imd*id1+((rme-imd))*id2,& + & min(imd*id1+(rme-imd)*id2+id2-1,np-1) ) ] + end if +!!$ write(0,*) me,rme,imd,' ISRC: ',isrc(:) + nsrc = size(isrc) +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',desc_out%get_local_rows(),desc_out%get_global_rows() + else +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',0,0 + end if + else + write(0,*) 'Right now only BLOCK on input ' + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Collect matrices on their destinations + ! + block + integer(psb_ipk_) :: nzsnd, nzrcv, ip + integer(psb_ipk_) :: nrl, ncl, nzl, nzp + call a_in%cp_to(acoo_snd) + nzsnd = acoo_snd%get_nzeros() + call psb_snd(ctxt,nzsnd,ipd) + call psb_snd(ctxt,desc_in%get_local_rows(),ipd) + ! Convert to global numbering + call psb_loc_to_glob(acoo_snd%ia(1:nzsnd),desc_in,info) + call psb_loc_to_glob(acoo_snd%ja(1:nzsnd),desc_in,info) + + call psb_snd(ctxt,acoo_snd%ia(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%ja(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%val(1:nzsnd),ipd) + + if (rme>=0) then + ! prepare to receive + nzsrc = isrc + nrsrc = isrc + nzl = 0 + do ip=1, nsrc + call psb_rcv(ctxt,nzsrc(ip),isrc(ip)) + call psb_rcv(ctxt,nrsrc(ip),isrc(ip)) + nzl = nzl + nzsrc(ip) + end do +!!$ write(0,*) rme,' Check on NR:',newnl(rme+1),sum(nrsrc) + call acoo_rcv%allocate(newnl(rme+1),newnl(rme+1),nzl) + nrl = acoo_rcv%get_nrows() + ncl = acoo_rcv%get_ncols() + nzp = 0 + do ip=1, nsrc + call psb_rcv(ctxt,acoo_rcv%ia(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%ja(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%val(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + nzp = nzp + nzsrc(ip) + end do + call acoo_rcv%set_nzeros(nzp) +!!$ write(0,*) rme,' Collected: ',& +!!$ & acoo_rcv%get_nrows(),acoo_rcv%get_ncols(),acoo_rcv%get_nzeros() + + ! + ! New descriptor + ! + call psb_cdall(newctxt,desc_out,info,nl=newnl(rme+1)) + ! Insert + call psb_spall(a_out,desc_out,info) + call psb_spins(nzp,acoo_rcv%ia(1:nzp),acoo_rcv%ja(1:nzp),& + & acoo_rcv%val(1:nzp),a_out,desc_out,info) + ! Assemble + call psb_cdasb(desc_out,info) + call psb_spasb(a_out,desc_out,info) + +!!$ write(0,*) rme,' Regenerated: ',& +!!$ & desc_out%get_local_rows(), desc_out%get_local_cols(),& +!!$ & a_out%get_nrows(),a_out%get_ncols(),a_out%get_nzeros() + naggr(me+1) = desc_out%get_local_rows() + else + naggr(me+1) = 0 + end if + call psb_sum(ctxt,naggr) + + end block + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_c_remap diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index 19924fbe..530a43a2 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -52,7 +52,7 @@ subroutine psb_calloc_vect(x, desc_a,info) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -63,9 +63,9 @@ subroutine psb_calloc_vect(x, desc_a,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -105,7 +105,7 @@ subroutine psb_calloc_vect(x, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -133,8 +133,9 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) integer(psb_ipk_), optional, intent(in) :: n,lb !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -145,9 +146,9 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -176,9 +177,9 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -216,7 +217,7 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -235,8 +236,9 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) integer(psb_ipk_), optional, intent(in) :: n !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -247,9 +249,9 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -273,9 +275,9 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -308,7 +310,7 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_callc_a.f90 b/base/tools/psb_callc_a.f90 index df3a41b1..5ae9dac5 100644 --- a/base/tools/psb_callc_a.f90 +++ b/base/tools/psb_callc_a.f90 @@ -55,7 +55,8 @@ subroutine psb_calloc(x, desc_a, info, n, lb) !locals integer(psb_ipk_) :: err,nr,i,j,n_,err_act - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: exch(3) character(len=20) :: name @@ -67,9 +68,9 @@ subroutine psb_calloc(x, desc_a, info, n, lb) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -91,9 +92,9 @@ subroutine psb_calloc(x, desc_a, info, n, lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -124,7 +125,7 @@ subroutine psb_calloc(x, desc_a, info, n, lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_callocv(x, desc_a,info,n) !locals integer(psb_ipk_) :: nr,i,err_act - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -196,9 +198,9 @@ subroutine psb_callocv(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -238,7 +240,7 @@ subroutine psb_callocv(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index b7e57549..78d28f02 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -62,7 +62,8 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -73,13 +74,13 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) name = 'psb_cgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -117,7 +118,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -135,7 +136,8 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me, i, n + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, i, n integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -146,13 +148,13 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) name = 'psb_cgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -198,7 +200,7 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -217,7 +219,8 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ @@ -229,7 +232,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) name = 'psb_cgeasb' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -246,7 +249,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) end if endif - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -286,7 +289,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_casb_a.f90 b/base/tools/psb_casb_a.f90 index 5d4e4d6a..db7b23c8 100644 --- a/base/tools/psb_casb_a.f90 +++ b/base/tools/psb_casb_a.f90 @@ -52,7 +52,8 @@ subroutine psb_casb(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,nrow,ncol, err_act integer(psb_ipk_) :: i1sz, i2sz integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -74,9 +75,9 @@ subroutine psb_casb(x, desc_a, info, scratch) call psb_errpush(info,name) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & @@ -96,7 +97,7 @@ subroutine psb_casb(x, desc_a, info, scratch) endif ! check size - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() i1sz = size(x,dim=1) @@ -129,7 +130,7 @@ subroutine psb_casb(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -188,7 +189,8 @@ subroutine psb_casbv(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -201,13 +203,13 @@ subroutine psb_casbv(x, desc_a, info, scratch) info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -252,7 +254,7 @@ subroutine psb_casbv(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_ccdbldext.F90 b/base/tools/psb_ccdbldext.F90 index b039cbeb..a9ead509 100644 --- a/base/tools/psb_ccdbldext.F90 +++ b/base/tools/psb_ccdbldext.F90 @@ -90,7 +90,9 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ integer(psb_lpk_) :: gidx, lnz - integer(psb_mpk_) :: icomm, ictxt, me, np, minfo + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_mpk_) :: icomm, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -114,9 +116,9 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) If (debug_level >= psb_debug_outer_) & & Write(debug_unit,*) me,' ',trim(name),& @@ -187,7 +189,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif ! ! Ok, since we are only estimating, do it as follows: @@ -215,7 +217,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_) then Write(debug_unit,*) me,' ',trim(name),':Start',& & lworks,lworkr, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif @@ -593,7 +595,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_move_alloc(t_halo_out,halo,info) ! @@ -672,7 +674,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),': converting indexes' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) @@ -701,7 +703,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index 010901b5..b12e845f 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -38,10 +38,10 @@ ! ! Arguments: ! v - integer(psb_ipk_), dimension(:). The array containg the partitioning scheme. -! ictxt - integer. The communication context. +! ctxt - integer. The communication context. ! desc - type(psb_desc_type). The communication descriptor. ! info - integer. Eventually returns an error code -subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) +subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx,usehash) use psb_base_mod use psi_mod use psb_repl_map_mod @@ -49,11 +49,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) use psb_hash_map_mod implicit None !....Parameters... - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_lpk_), intent(in) :: v(:) - integer(psb_ipk_), intent(out) :: info - type(psb_desc_type), intent(out) :: desc - logical, intent(in), optional :: globalcheck,usehash + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_lpk_), intent(in) :: v(:) + integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(out) :: desc + logical, intent(in), optional :: globalcheck,usehash integer(psb_ipk_), intent(in), optional :: idx(:) !locals @@ -81,18 +81,18 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': start',np if (do_timings) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() end if loc_row = size(v) m = maxval(v) nrt = loc_row - call psb_sum(ictxt,nrt) - call psb_max(ictxt,m) + call psb_sum(ctxt,nrt) + call psb_max(ctxt,m) if (present(globalcheck)) then check_ = globalcheck @@ -126,9 +126,9 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) exch(1)=m exch(2)=n exch(3)=psb_cd_get_large_threshold() - call psb_bcast(ictxt,exch(1:3),root=psb_root_) + call psb_bcast(ctxt,exch(1:3),root=psb_root_) else - call psb_bcast(ictxt,exch(1:3),root=psb_root_) + call psb_bcast(ctxt,exch(1:3),root=psb_root_) if (exch(1) /= m) then err=550 l_err(1)=1 @@ -191,8 +191,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) end do if (info == psb_success_) then - call psb_amx(ictxt,tmpgidx(:,1)) - call psb_sum(ictxt,tmpgidx(:,2)) + call psb_amx(ctxt,tmpgidx(:,1)) + call psb_sum(ctxt,tmpgidx(:,2)) novrl = 0 npr_ov = 0 norphan = 0 @@ -236,7 +236,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) & write(debug_unit,*) me,' ',trim(name),': After global checks ' if (do_timings) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() end if @@ -276,7 +276,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) call psb_nullify_desc(desc) if (do_timings) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() end if @@ -307,7 +307,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) nov(me) = nov(me) + 1 end if end do - call psb_sum(ictxt,nov) + call psb_sum(ctxt,nov) nov(1:np) = nov(0:np-1) nov(0) = 1 do i=1, np @@ -329,7 +329,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) call psb_errpush(info,name,a_err='overlap count') goto 9999 end if - call psb_max(ictxt,ov_idx) + call psb_max(ctxt,ov_idx) call psb_msort(ov_idx(:,1),ix=ov_idx(:,2),flag=psb_sort_keep_idx_) end if @@ -388,7 +388,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) end do end if if (do_timings) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) t3 = psb_wtime() end if if (debug_size) & @@ -406,9 +406,9 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(ctxt,m,info) class default - call aa%init(ictxt,vl(1:nlu),info) + call aa%init(ctxt,vl(1:nlu),info) end select if (debug_size) & @@ -416,7 +416,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) if (do_timings) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) t4 = psb_wtime() end if @@ -457,7 +457,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) endif if (do_timings) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) t5 = psb_wtime() t5 = t5 - t4 @@ -465,11 +465,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) t3 = t3 - t2 t2 = t2 - t1 t1 = t1 - t0 - call psb_amx(ictxt,t1) - call psb_amx(ictxt,t2) - call psb_amx(ictxt,t3) - call psb_amx(ictxt,t4) - call psb_amx(ictxt,t5) + call psb_amx(ctxt,t1) + call psb_amx(ctxt,t2) + call psb_amx(ctxt,t3) + call psb_amx(ctxt,t4) + call psb_amx(ctxt,t5) if (me==0) then write(0,*) 'CD_INLOC Timings: ' write(0,*) ' Phase 1 : ', t1 @@ -485,7 +485,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx,usehash) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cd_lstext.f90 b/base/tools/psb_cd_lstext.f90 index d8f60f25..f96abd9c 100644 --- a/base/tools/psb_cd_lstext.f90 +++ b/base/tools/psb_cd_lstext.f90 @@ -38,15 +38,16 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) ! .. Array Arguments .. Type(psb_desc_type), Intent(inout), target :: desc_a - integer(psb_lpk_), intent(in) :: in_list(:) + integer(psb_lpk_), intent(in) :: in_list(:) Type(psb_desc_type), Intent(out) :: desc_ov - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info logical, intent(in), optional, target :: mask(:) - integer(psb_ipk_), intent(in),optional :: extype + integer(psb_ipk_), intent(in),optional :: extype ! .. Local Scalars .. - integer(psb_ipk_) :: i, j, np, me,m,nnzero,& - & ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),& + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: i, j, np, me,m,nnzero,& + & lovr, lworks,lworkr, n_row,n_col, int_err(5),& & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& @@ -70,8 +71,8 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) If (debug_level >= psb_debug_outer_) & & Write(debug_unit,*) me,' ',trim(name),': start',size(in_list) @@ -133,7 +134,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),': converting indexes' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) @@ -153,7 +154,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cd_reinit.f90 b/base/tools/psb_cd_reinit.f90 index 15dbbc59..d294cfc0 100644 --- a/base/tools/psb_cd_reinit.f90 +++ b/base/tools/psb_cd_reinit.f90 @@ -41,13 +41,14 @@ Subroutine psb_cd_reinit(desc,info) Type(psb_desc_type), Intent(inout) :: desc integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: icomm, err_act ! .. Local Scalars .. - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_mpk_) :: icomm integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ext(:), tmp_ovr(:) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name, ch_err name='psb_cd_reinit' info = psb_success_ @@ -55,9 +56,9 @@ Subroutine psb_cd_reinit(desc,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc%get_context() + ctxt = desc%get_context() icomm = desc%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': start' if (desc%is_asb()) then @@ -81,7 +82,7 @@ Subroutine psb_cd_reinit(desc,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cd_renum_block.F90 b/base/tools/psb_cd_renum_block.F90 index 1d64a09e..e78e9079 100644 --- a/base/tools/psb_cd_renum_block.F90 +++ b/base/tools/psb_cd_renum_block.F90 @@ -53,10 +53,11 @@ subroutine psb_cd_renum_block(desc_in, desc_out, info) type(psb_gen_block_map), allocatable :: blck_map integer(psb_ipk_), allocatable :: lidx(:),reflidx(:) integer(psb_lpk_), allocatable :: gidx(:),vnl(:) - integer(psb_ipk_) :: i, n_row, n_col - integer(psb_lpk_) :: li, n_glob_row, n_glob_col - integer(psb_ipk_) :: np, me, ictxt, err_act - integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: i, n_row, n_col + integer(psb_lpk_) :: li, n_glob_row, n_glob_col + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name debug_unit = psb_get_debug_unit() @@ -67,10 +68,10 @@ subroutine psb_cd_renum_block(desc_in, desc_out, info) call psb_erractionsave(err_act) name = 'psb_cd_renum_block' - ictxt = desc_in%get_context() + ctxt = desc_in%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': Entered' if (np == -1) then @@ -99,7 +100,7 @@ subroutine psb_cd_renum_block(desc_in, desc_out, info) n_glob_col = desc_in%get_global_cols() vnl = 0 vnl(me) = n_row - call psb_sum(ictxt,vnl) + call psb_sum(ctxt,vnl) vnl(1:np) = vnl(0:np-1) vnl(0) = 0 do i=1,np @@ -123,7 +124,7 @@ subroutine psb_cd_renum_block(desc_in, desc_out, info) reflidx(1:n_col) = [(i,i=1,n_col)] gidx(1:n_row) = reflidx(1:n_row) + vnl(me) call psb_halo(gidx,desc_in,info) - if (info == 0) call blck_map%gen_block_map_init(ictxt,n_row,info) + if (info == 0) call blck_map%gen_block_map_init(ctxt,n_row,info) if (info == 0) call blck_map%g2l_ins(gidx,lidx,info,lidx=reflidx) if (info == 0) call blck_map%asb(info) if (info == 0) call & @@ -148,7 +149,7 @@ subroutine psb_cd_renum_block(desc_in, desc_out, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cd_set_bld.f90 b/base/tools/psb_cd_set_bld.f90 index 54133cf5..ecce17f9 100644 --- a/base/tools/psb_cd_set_bld.f90 +++ b/base/tools/psb_cd_set_bld.f90 @@ -53,7 +53,8 @@ subroutine psb_cd_set_bld(desc,info) type(psb_desc_type), intent(inout) :: desc integer(psb_ipk_) :: info !locals - integer(psb_ipk_) :: np,me,ictxt, err_act,idx,gidx,lidx,nc + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act,idx,gidx,lidx,nc logical, parameter :: debug=.false.,debugprt=.false. character(len=20) :: name if (debug) write(psb_err_unit,*) me,'Entered CDCPY' @@ -62,11 +63,11 @@ subroutine psb_cd_set_bld(desc,info) call psb_erractionsave(err_act) name = 'psb_cd_set_bld' - ictxt = desc%get_context() + ctxt = desc%get_context() - if (debug) write(psb_err_unit,*)'Entered CDSETBLD',ictxt + if (debug) write(psb_err_unit,*)'Entered CDSETBLD' ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug) write(psb_err_unit,*) me,'Entered CDSETBLD' if (desc%is_asb()) call psb_cd_reinit(desc,info) @@ -77,7 +78,7 @@ subroutine psb_cd_set_bld(desc,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cd_switch_ovl_indxmap.f90 b/base/tools/psb_cd_switch_ovl_indxmap.f90 index b2bdd9e4..10ce794e 100644 --- a/base/tools/psb_cd_switch_ovl_indxmap.f90 +++ b/base/tools/psb_cd_switch_ovl_indxmap.f90 @@ -45,9 +45,10 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info) integer(psb_ipk_), intent(out) :: info ! .. Local Scalars .. - integer(psb_ipk_) :: i, j, np, me, ictxt, n_row, n_col - integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: i, j, np, me, n_row, n_col + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: err_act integer(psb_lpk_), allocatable :: vl(:) integer(psb_ipk_) :: debug_level, debug_unit, ierr(5) @@ -59,8 +60,8 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc%get_context() + Call psb_info(ctxt, me, np) If (debug_level >= psb_debug_outer_) & & Write(debug_unit,*) me,' ',trim(name),& @@ -90,14 +91,14 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info) call desc%indxmap%free() deallocate(desc%indxmap) - if (psb_cd_choose_large_state(ictxt,mglob)) then + if (psb_cd_choose_large_state(ctxt,mglob)) then allocate(psb_hash_map :: desc%indxmap, stat=info) else allocate(psb_list_map :: desc%indxmap, stat=info) end if if (info == psb_success_)& - & call desc%indxmap%init(ictxt,vl(1:n_row),info) + & call desc%indxmap%init(ctxt,vl(1:n_row),info) if (info == psb_success_) call psb_cd_set_bld(desc,info) if (info == psb_success_) & & call desc%indxmap%g2lip_ins(vl(n_row+1:n_col),info) @@ -126,7 +127,7 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cdall.f90 b/base/tools/psb_cdall.f90 index 15ce572f..e86eef0b 100644 --- a/base/tools/psb_cdall.f90 +++ b/base/tools/psb_cdall.f90 @@ -1,4 +1,5 @@ -subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalcheck,lidx,usehash) +subroutine psb_cdall(ctxt, desc, info,mg,ng,parts,& + & vg,vl,flag,nl,repl,globalcheck,lidx,usehash) use psb_desc_mod use psb_serial_mod use psb_const_mod @@ -7,46 +8,50 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec use psb_cd_tools_mod, psb_protect_name => psb_cdall use psi_mod implicit None - procedure(psb_parts) :: parts - integer(psb_lpk_), intent(in) :: mg,ng, vl(:) - integer(psb_ipk_), intent(in) :: ictxt, vg(:), lidx(:),nl - integer(psb_ipk_), intent(in) :: flag - logical, intent(in) :: repl, globalcheck,usehash - integer(psb_ipk_), intent(out) :: info - type(psb_desc_type), intent(out) :: desc + procedure(psb_parts) :: parts + integer(psb_lpk_), intent(in) :: mg,ng, vl(:) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: vg(:), lidx(:),nl + integer(psb_ipk_), intent(in) :: flag + logical, intent(in) :: repl, globalcheck,usehash + integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(out) :: desc optional :: mg,ng,parts,vg,vl,flag,nl,repl, globalcheck,lidx, usehash interface - subroutine psb_cdals(m, n, parts, ictxt, desc, info) + subroutine psb_cdals(m, n, parts, ctxt, desc, info) use psb_desc_mod procedure(psb_parts) :: parts integer(psb_lpk_), intent(in) :: m,n - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt Type(psb_desc_type), intent(out) :: desc integer(psb_ipk_), intent(out) :: info end subroutine psb_cdals - subroutine psb_cdalv(v, ictxt, desc, info, flag) + subroutine psb_cdalv(v, ctxt, desc, info, flag) use psb_desc_mod - integer(psb_ipk_), intent(in) :: ictxt, v(:) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: v(:) integer(psb_ipk_), intent(in), optional :: flag integer(psb_ipk_), intent(out) :: info Type(psb_desc_type), intent(out) :: desc end subroutine psb_cdalv - subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx, usehash) + subroutine psb_cd_inloc(v, ctxt, desc, info, globalcheck,idx, usehash) use psb_desc_mod implicit None - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt integer(psb_lpk_), intent(in) :: v(:) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(out) :: desc logical, intent(in), optional :: globalcheck, usehash integer(psb_ipk_), intent(in), optional :: idx(:) end subroutine psb_cd_inloc - subroutine psb_cdrep(m, ictxt, desc,info) + subroutine psb_cdrep(m, ctxt, desc,info) use psb_desc_mod integer(psb_lpk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt + + Type(psb_desc_type), intent(out) :: desc integer(psb_ipk_), intent(out) :: info end subroutine psb_cdrep @@ -65,7 +70,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec name = 'psb_cdall' call psb_erractionsave(err_act) - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (count((/ present(vg),present(vl),& & present(parts),present(nl), present(repl) /)) /= 1) then info=psb_err_no_optional_arg_ @@ -90,7 +95,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec else n_ = mg endif - call psb_cdals(mg, n_, parts, ictxt, desc, info) + call psb_cdals(mg, n_, parts, ctxt, desc, info) else if (present(repl)) then @@ -105,7 +110,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec goto 9999 end if - call psb_cdrep(mg, ictxt, desc, info) + call psb_cdrep(mg, ctxt, desc, info) else if (present(vg)) then @@ -121,7 +126,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec nnv = size(vg) end if - call psb_cdalv(vg(1:nnv), ictxt, desc, info, flag=flag_) + call psb_cdalv(vg(1:nnv), ctxt, desc, info, flag=flag_) else if (present(vl)) then @@ -131,7 +136,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec nnv = size(vl) end if - call psb_cd_inloc(vl(1:nnv),ictxt,desc,info, globalcheck=globalcheck,idx=lidx) + call psb_cd_inloc(vl(1:nnv),ctxt,desc,info, globalcheck=globalcheck,idx=lidx) else if (present(nl)) then @@ -143,9 +148,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec if (usehash_) then nlp = nl - call psb_exscan_sum(ictxt,nlp) + call psb_exscan_sum(ctxt,nlp) lvl = [ (i,i=1,nl) ] + nlp - call psb_cd_inloc(lvl(1:nl),ictxt,desc,info, globalcheck=.false.) + call psb_cd_inloc(lvl(1:nl),ctxt,desc,info, globalcheck=.false.) else if (np == 1) then @@ -157,9 +162,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec select type(aa => desc%indxmap) type is (psb_repl_map) n_ = nl - call aa%repl_map_init(ictxt,n_,info) + call aa%repl_map_init(ctxt,n_,info) type is (psb_gen_block_map) - call aa%gen_block_map_init(ictxt,nl,info) + call aa%gen_block_map_init(ctxt,nl,info) class default ! This cannot happen info = psb_err_internal_error_ @@ -197,7 +202,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,globalchec call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index dfee4113..1387b1a8 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -40,22 +40,22 @@ ! n - integer. The number of columns. ! parts - external subroutine. The routine that contains the ! partitioning scheme. -! ictxt - integer. The communication context. +! ctxt - integer. The communication context. ! desc - type(psb_desc_type). The communication descriptor. ! info - integer. Error code (if any). -subroutine psb_cdals(m, n, parts, ictxt, desc, info) +subroutine psb_cdals(m, n, parts, ctxt, desc, info) use psb_base_mod use psi_mod use psb_repl_map_mod use psb_list_map_mod use psb_hash_map_mod implicit None - procedure(psb_parts) :: parts + procedure(psb_parts) :: parts !....Parameters... - integer(psb_lpk_), intent(in) :: M,N - integer(psb_ipk_), intent(in) :: ictxt - Type(psb_desc_type), intent(out) :: desc - integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in) :: M,N + type(psb_ctxt_type), intent(in) :: ctxt + Type(psb_desc_type), intent(out) :: desc + integer(psb_ipk_), intent(out) :: info !locals integer(psb_ipk_) :: counter,i,j,loc_row,err,loc_col,& @@ -77,7 +77,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': ',np ! ....verify blacs grid correctness.. @@ -100,9 +100,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) !global check on m and n parameters if (me == psb_root_) then exch(1)=m; exch(2)=n; exch(3)=psb_cd_get_large_threshold() - call psb_bcast(ictxt,exch(1:3),root=psb_root_) + call psb_bcast(ctxt,exch(1:3),root=psb_root_) else - call psb_bcast(ictxt,exch(1:3),root=psb_root_) + call psb_bcast(ctxt,exch(1:3),root=psb_root_) if (exch(1) /= m) then err=550 call psb_errpush(err,name,m_err=(/1/)) @@ -240,9 +240,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(ctxt,m,info) class default - call aa%init(ictxt,loc_idx(1:k),info) + call aa%init(ctxt,loc_idx(1:k),info) end select @@ -285,7 +285,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index 8b850f6b..28d2ecc3 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -39,11 +39,11 @@ ! ! Arguments: ! v - integer(psb_ipk_), dimension(:). The array containg the partitioning scheme. -! ictxt - integer. The communication context. +! ctxt - integer. The communication context. ! desc - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! flag - integer. Are V's contents 0- or 1-based? -subroutine psb_cdalv(v, ictxt, desc, info, flag) +subroutine psb_cdalv(v, ctxt, desc, info, flag) use psb_base_mod use psi_mod use psb_repl_map_mod @@ -51,9 +51,10 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) use psb_hash_map_mod implicit None !....Parameters... - integer(psb_ipk_), intent(in) :: ictxt, v(:) - integer(psb_ipk_), intent(in), optional :: flag - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_), intent(in) :: v(:) + integer(psb_ipk_), intent(in), optional :: flag + integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(out) :: desc !locals @@ -73,7 +74,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) err = 0 name = 'psb_cdalv' - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': ',np,me m = size(v) @@ -102,9 +103,9 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) exch(1)=m exch(2)=n exch(3)=psb_cd_get_large_threshold() - call psb_bcast(ictxt,exch(1:3),root=psb_root_) + call psb_bcast(ctxt,exch(1:3),root=psb_root_) else - call psb_bcast(ictxt,exch(1:3),root=psb_root_) + call psb_bcast(ctxt,exch(1:3),root=psb_root_) if (exch(1) /= m) then err=550 l_err(1)=1 @@ -178,7 +179,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) if (np == 1) then allocate(psb_repl_map :: desc%indxmap, stat=info) else - if (psb_cd_choose_large_state(ictxt,m)) then + if (psb_cd_choose_large_state(ctxt,m)) then allocate(psb_hash_map :: desc%indxmap, stat=info) if (info == 0) allocate(desc%indxmap%tempvg(m),stat=info) if (info ==0) desc%indxmap%tempvg(1:m) = v(1:m) - flag_ @@ -190,11 +191,11 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(ctxt,m,info) type is (psb_hash_map) - call aa%hash_map_init(ictxt,v,info) + call aa%hash_map_init(ctxt,v,info) type is (psb_glist_map) - call aa%glist_map_init(ictxt,v,info) + call aa%glist_map_init(ctxt,v,info) class default ! This cannot happen info = psb_err_internal_error_ @@ -218,7 +219,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cdcpy.F90 b/base/tools/psb_cdcpy.F90 index 7605006a..d44c0c95 100644 --- a/base/tools/psb_cdcpy.F90 +++ b/base/tools/psb_cdcpy.F90 @@ -29,14 +29,14 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - ! - ! Subroutine: psb_cdcpy - ! Produces a clone of a descriptor. - ! - ! Arguments: - ! desc_in - type(psb_desc_type). The communication descriptor to be cloned. - ! desc_out - type(psb_desc_type). The output communication descriptor. - ! info - integer. Return code. +! +! Subroutine: psb_cdcpy +! Produces a clone of a descriptor. +! +! Arguments: +! desc_in - type(psb_desc_type). The communication descriptor to be cloned. +! desc_out - type(psb_desc_type). The output communication descriptor. +! info - integer. Return code. subroutine psb_cdcpy(desc_in, desc_out, info) use psb_base_mod, psb_protect_name => psb_cdcpy @@ -49,7 +49,8 @@ subroutine psb_cdcpy(desc_in, desc_out, info) integer(psb_ipk_), intent(out) :: info !locals - integer(psb_ipk_) :: np,me,ictxt, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -61,10 +62,10 @@ subroutine psb_cdcpy(desc_in, desc_out, info) call psb_erractionsave(err_act) name = 'psb_cdcpy' - ictxt = desc_in%get_context() + ctxt = desc_in%get_context() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': Entered' if (np == -1) then @@ -86,7 +87,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cdins.F90 b/base/tools/psb_cdins.F90 index d1b186f9..4de000db 100644 --- a/base/tools/psb_cdins.F90 +++ b/base/tools/psb_cdins.F90 @@ -74,11 +74,12 @@ subroutine psb_lcdinsrc(nz,ia,ja,desc_a,info,ila,jla) integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(out) :: ila(:), jla(:) - !LOCALS..... - integer(psb_ipk_) :: ictxt,dectype,mglob, nglob - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: nrow,ncol, err_act + !LOCALS..... + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: dectype,mglob, nglob + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: nrow,ncol, err_act logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila_(:), jla_(:) @@ -94,14 +95,14 @@ subroutine psb_lcdinsrc(nz,ia,ja,desc_a,info,ila,jla) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() dectype = desc_a%get_dectype() mglob = desc_a%get_global_rows() nglob = desc_a%get_global_cols() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -160,7 +161,7 @@ subroutine psb_lcdinsrc(nz,ia,ja,desc_a,info,ila,jla) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -218,11 +219,11 @@ subroutine psb_lcdinsc(nz,ja,desc,info,jla,mask,lidx) !LOCALS..... - - integer(psb_ipk_) :: ictxt,dectype,mglob, nglob - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: nrow,ncol, err_act - logical, parameter :: debug=.false. + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: dectype,mglob, nglob + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: nrow,ncol, err_act + logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila_(:), jla_(:) character(len=20) :: name @@ -238,14 +239,14 @@ subroutine psb_lcdinsc(nz,ja,desc,info,jla,mask,lidx) goto 9999 endif - ictxt = desc%get_context() + ctxt = desc%get_context() dectype = desc%get_dectype() mglob = desc%get_global_rows() nglob = desc%get_global_cols() nrow = desc%get_local_rows() ncol = desc%get_local_cols() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -298,7 +299,7 @@ subroutine psb_lcdinsc(nz,ja,desc,info,jla,mask,lidx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cdprt.f90 b/base/tools/psb_cdprt.f90 index 1f68c73d..0ee64f2a 100644 --- a/base/tools/psb_cdprt.f90 +++ b/base/tools/psb_cdprt.f90 @@ -52,10 +52,11 @@ subroutine psb_cdprt(iout,desc_p,glob,short, verbosity) integer(psb_ipk_) :: m, n_row, n_col,counter,idx,& & n_elem_recv,n_elem_send,proc,i, verb_ - integer(psb_ipk_) :: ictxt, me, np - integer(psb_ipk_) :: total_snd, total_rcv, total_xhcg, global_halo, global_points - integer(psb_ipk_) :: local_snd, local_rcv, local_xhcg, local_halo, local_points - real(psb_dpk_) :: av2s, v2s + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_ipk_) :: total_snd, total_rcv, total_xhcg, global_halo, global_points + integer(psb_ipk_) :: local_snd, local_rcv, local_xhcg, local_halo, local_points + real(psb_dpk_) :: av2s, v2s if (present(glob)) then glob_ = glob @@ -73,9 +74,9 @@ subroutine psb_cdprt(iout,desc_p,glob,short, verbosity) verb_ = 1 endif - ictxt = desc_p%get_ctxt() - call psb_info(ictxt, me,np) - call psb_min(ictxt,verb_) + ctxt = desc_p%get_ctxt() + call psb_info(ctxt, me,np) + call psb_min(ctxt,verb_) ! ! Level 1: Print global info @@ -91,8 +92,8 @@ subroutine psb_cdprt(iout,desc_p,glob,short, verbosity) global_halo = local_halo av2s = v2s - call psb_sum(ictxt, global_halo) - call psb_sum(ictxt, av2s) + call psb_sum(ctxt, global_halo) + call psb_sum(ctxt, av2s) av2s = av2s / np if (me == psb_root_) then write(iout,*) ' Communication descriptor details ' @@ -102,7 +103,7 @@ subroutine psb_cdprt(iout,desc_p,glob,short, verbosity) write(iout,*) ' Average volume to surface ratio :',av2s write(iout,*) end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (verb_ <= 1) return @@ -119,21 +120,21 @@ subroutine psb_cdprt(iout,desc_p,glob,short, verbosity) write(iout,*) me,': Volume to surface ratio:',0.0_psb_dpk_ end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) end do if (me==psb_root_) write(iout,*) 'Communication data for : comm_halo' do i=0, np-1 if (me == i) & & call print_my_xchg(iout,desc_p,verbosity=verb_,data=psb_comm_halo_,glob=glob_) - call psb_barrier(ictxt) + call psb_barrier(ctxt) end do if (me==psb_root_) write(iout,*) 'Communication data for : comm_ext' do i=0, np-1 if (me == i) & & call print_my_xchg(iout,desc_p,verbosity=verb_,data=psb_comm_ext_,glob=glob_) - call psb_barrier(ictxt) + call psb_barrier(ctxt) end do return @@ -147,13 +148,14 @@ contains logical, intent(in), optional :: glob,short logical :: short_, glob_ - integer(psb_ipk_) :: ip, nerv, nesd, totxch,idxr,idxs - integer(psb_ipk_) :: ictxt, me, np, data_, info, verb_ + integer(psb_ipk_) :: ip, nerv, nesd, totxch,idxr,idxs + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, data_, info, verb_ integer(psb_lpk_), allocatable :: gidx(:) class(psb_i_base_vect_type), pointer :: vpnt - ictxt = desc_p%get_ctxt() - call psb_info(ictxt, me,np) + ctxt = desc_p%get_ctxt() + call psb_info(ctxt, me,np) if (present(data)) then data_ = data else diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index 95568a8e..f80c21ba 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -56,11 +56,12 @@ subroutine psb_cdren(trans,iperm,desc_a,info) character, intent(in) :: trans integer(psb_ipk_), intent(out) :: info !....locals.... - integer(psb_ipk_) :: i,j,np,me, n_col, kh, nh - integer(psb_ipk_) :: dectype - integer(psb_ipk_) :: ictxt,n_row, err_act - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name + integer(psb_ipk_) :: i,j,np,me, n_col, kh, nh + integer(psb_ipk_) :: dectype + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: n_row, err_act + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name if(psb_get_errstatus() /= 0) return info=psb_success_ @@ -69,13 +70,13 @@ subroutine psb_cdren(trans,iperm,desc_a,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() dectype = desc_a%get_dectype() n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -151,7 +152,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index 2ba47c2c..b6f6bfb7 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -29,88 +29,88 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - ! Purpose - ! == = ==== - ! - ! Allocate special descriptor for replicated index space. - ! - ! - ! - ! INPUT - ! == ==== - ! M :(Global Input) Integer - ! Total number of equations - ! required. - ! - ! ictxt : (Global Input)Integer BLACS context for an NPx1 grid - ! required. - ! - ! OUTPUT - ! == ======= - ! desc : TYPEDESC - ! desc OUTPUT FIELDS: - ! - ! MATRIX_DATA : Pointer to integer Array - ! contains some - ! local and global information about matrix: - ! - ! NOTATION STORED IN EXPLANATION - ! ------------ ---------------------- ------------------------------------- - ! DEC_TYPE MATRIX_DATA[DEC_TYPE_] Decomposition type, temporarly is - ! setted to 1( matrix not yet assembled) - ! M MATRIX_DATA[M_] Total number of equations - ! N MATRIX_DATA[N_] Total number of variables - ! N_ROW MATRIX_DATA[N_ROW_] Number of local equations - ! N_COL MATRIX_DATA[N_COL_] Number of local columns (see below) - ! CTXT_A MATRIX_DATA[CTXT_] The BLACS context handle, - ! indicating - ! the global context of the operation - ! on the matrix. - ! The context itself is global. - ! - ! GLOB_TO_LOC Array of dimension equal to number of global - ! rows/cols (MATRIX_DATA[M_]). On exit, - ! for all global indices either: - ! 1. The index belongs to the current process; the entry - ! is set to the next free local row index. - ! 2. The index belongs to process P (0<=P<=NP-1); the entry - ! is set to - ! -(NP+P+1) - ! - ! LOC_TO_GLOB An array of dimension equal to number of local cols N_COL - ! i.e. all columns of the matrix such that there is at least - ! one nonzero entry within the local row range. At the time - ! this routine is called N_COL cannot be know, so we set - ! N_COL=N_ROW, and dimension this vector on N_ROW plus an - ! estimate. On exit the vector elements are set - ! to the index of the corresponding entry in GLOB_TO_LOC, or - ! to -1 for indices I>N_ROW. - ! - ! - ! HALO_INDEX Not touched here, as it depends on the matrix pattern - ! - ! OVRLAP_INDEX On exit from this routine, the overlap indices are stored in - ! triples (Proc, 1, Index), similar to the assembled format - ! but neither optimized, nor deadlock free. - ! List is terminated with -1 - ! - ! OVRLAP_ELEM On exit from this routine, just a list of pairs (index,#p). - ! List is terminated with -1. - ! - ! - ! END OF desc OUTPUT FIELDS - ! - ! -subroutine psb_cdrep(m, ictxt, desc, info) +! Purpose +! == = ==== +! +! Allocate special descriptor for replicated index space. +! +! +! +! INPUT +! == ==== +! M :(Global Input) Integer +! Total number of equations +! required. +! +! ctxt : (Global Input)Integer BLACS context for an NPx1 grid +! required. +! +! OUTPUT +! == ======= +! desc : TYPEDESC +! desc OUTPUT FIELDS: +! +! MATRIX_DATA : Pointer to integer Array +! contains some +! local and global information about matrix: +! +! NOTATION STORED IN EXPLANATION +! ------------ ---------------------- ------------------------------------- +! DEC_TYPE MATRIX_DATA[DEC_TYPE_] Decomposition type, temporarly is +! setted to 1( matrix not yet assembled) +! M MATRIX_DATA[M_] Total number of equations +! N MATRIX_DATA[N_] Total number of variables +! N_ROW MATRIX_DATA[N_ROW_] Number of local equations +! N_COL MATRIX_DATA[N_COL_] Number of local columns (see below) +! CTXT_A MATRIX_DATA[CTXT_] The BLACS context handle, +! indicating +! the global context of the operation +! on the matrix. +! The context itself is global. +! +! GLOB_TO_LOC Array of dimension equal to number of global +! rows/cols (MATRIX_DATA[M_]). On exit, +! for all global indices either: +! 1. The index belongs to the current process; the entry +! is set to the next free local row index. +! 2. The index belongs to process P (0<=P<=NP-1); the entry +! is set to +! -(NP+P+1) +! +! LOC_TO_GLOB An array of dimension equal to number of local cols N_COL +! i.e. all columns of the matrix such that there is at least +! one nonzero entry within the local row range. At the time +! this routine is called N_COL cannot be know, so we set +! N_COL=N_ROW, and dimension this vector on N_ROW plus an +! estimate. On exit the vector elements are set +! to the index of the corresponding entry in GLOB_TO_LOC, or +! to -1 for indices I>N_ROW. +! +! +! HALO_INDEX Not touched here, as it depends on the matrix pattern +! +! OVRLAP_INDEX On exit from this routine, the overlap indices are stored in +! triples (Proc, 1, Index), similar to the assembled format +! but neither optimized, nor deadlock free. +! List is terminated with -1 +! +! OVRLAP_ELEM On exit from this routine, just a list of pairs (index,#p). +! List is terminated with -1. +! +! +! END OF desc OUTPUT FIELDS +! +! +subroutine psb_cdrep(m, ctxt, desc, info) use psb_base_mod use psi_mod use psb_repl_map_mod implicit None !....Parameters... - integer(psb_lpk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: info - Type(psb_desc_type), intent(out) :: desc + integer(psb_lpk_), intent(in) :: m + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(out) :: info + Type(psb_desc_type), intent(out) :: desc !locals integer(psb_ipk_) :: i,np,me,err,err_act @@ -127,7 +127,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': ',np n = m @@ -153,9 +153,9 @@ subroutine psb_cdrep(m, ictxt, desc, info) if (me == psb_root_) then exch(1)=m exch(2)=n - call psb_bcast(ictxt,exch(1:2),root=psb_root_) + call psb_bcast(ctxt,exch(1:2),root=psb_root_) else - call psb_bcast(ictxt,exch(1:2),root=psb_root_) + call psb_bcast(ctxt,exch(1:2),root=psb_root_) if (exch(1) /= m) then info=psb_err_parm_differs_among_procs_ l_err(1)=1 @@ -180,7 +180,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) allocate(psb_repl_map :: desc%indxmap, stat=info) select type(aa => desc%indxmap) type is (psb_repl_map) - call aa%repl_map_init(ictxt,m,info) + call aa%repl_map_init(ctxt,m,info) class default ! This cannot happen info = psb_err_internal_error_ @@ -198,7 +198,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_cdrep diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 index 2d38887a..54c728f5 100644 --- a/base/tools/psb_cfree.f90 +++ b/base/tools/psb_cfree.f90 @@ -46,7 +46,8 @@ subroutine psb_cfree_vect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -60,9 +61,9 @@ subroutine psb_cfree_vect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -86,7 +87,7 @@ subroutine psb_cfree_vect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -100,7 +101,8 @@ subroutine psb_cfree_vect_r2(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act, i + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act, i character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psb_cfree_vect_r2(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +139,7 @@ subroutine psb_cfree_vect_r2(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -152,7 +154,8 @@ subroutine psb_cfree_multivect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -166,9 +169,9 @@ subroutine psb_cfree_multivect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +195,7 @@ subroutine psb_cfree_multivect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cfree_a.f90 b/base/tools/psb_cfree_a.f90 index 38621be4..a8746071 100644 --- a/base/tools/psb_cfree_a.f90 +++ b/base/tools/psb_cfree_a.f90 @@ -48,7 +48,8 @@ subroutine psb_cfree(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_cfree' @@ -64,9 +65,9 @@ subroutine psb_cfree(x, desc_a, info) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -92,7 +93,7 @@ subroutine psb_cfree(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -116,7 +117,8 @@ subroutine psb_cfreev(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_cfreev' @@ -131,9 +133,9 @@ subroutine psb_cfreev(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -157,7 +159,7 @@ subroutine psb_cfreev(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cgetelem.f90 b/base/tools/psb_cgetelem.f90 index 728b4d1e..2789d1e4 100644 --- a/base/tools/psb_cgetelem.f90 +++ b/base/tools/psb_cgetelem.f90 @@ -55,7 +55,8 @@ function psb_c_getelem(x,index,desc_a,info) result(res) !locals integer(psb_ipk_) :: localindex(1) - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_lpk_) :: gindex(1) integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) character(len=20) :: name @@ -74,9 +75,9 @@ function psb_c_getelem(x,index,desc_a,info) result(res) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -95,7 +96,7 @@ function psb_c_getelem(x,index,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index cfb82b88..e874c315 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -63,7 +63,8 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -79,9 +80,9 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -145,7 +146,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -190,7 +191,8 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) complex(psb_spk_), allocatable :: lval(:) logical :: local_ @@ -207,9 +209,9 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -267,7 +269,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -295,7 +297,8 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -311,9 +314,9 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -381,7 +384,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -425,9 +429,9 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -491,7 +495,7 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cins_a.f90 b/base/tools/psb_cins_a.f90 index 6e67a0e6..688d06e9 100644 --- a/base/tools/psb_cins_a.f90 +++ b/base/tools/psb_cins_a.f90 @@ -68,7 +68,8 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -86,9 +87,9 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -169,7 +170,7 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -248,7 +249,8 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me,dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -266,9 +268,9 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -359,7 +361,7 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cspalloc.f90 b/base/tools/psb_cspalloc.f90 index b67aeede..69b9e1c2 100644 --- a/base/tools/psb_cspalloc.f90 +++ b/base/tools/psb_cspalloc.f90 @@ -52,7 +52,8 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit @@ -67,10 +68,10 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() dectype = desc_a%get_dectype() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -101,7 +102,7 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=nnz_) + call a%allocate(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='sp_all') @@ -117,7 +118,7 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 index 073fcbbd..96ed7fe7 100644 --- a/base/tools/psb_cspasb.f90 +++ b/base/tools/psb_cspasb.f90 @@ -62,7 +62,8 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_c_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -73,12 +74,12 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl, mold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() ! check on BLACS grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +138,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cspfree.f90 b/base/tools/psb_cspfree.f90 index 6defa911..51f40259 100644 --- a/base/tools/psb_cspfree.f90 +++ b/base/tools/psb_cspfree.f90 @@ -48,7 +48,8 @@ subroutine psb_cspfree(a, desc_a,info) type(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act character(len=20) :: name info=psb_success_ @@ -63,7 +64,7 @@ subroutine psb_cspfree(a, desc_a,info) call psb_errpush(info,name) return else - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() end if !...deallocate a.... @@ -72,7 +73,7 @@ subroutine psb_cspfree(a, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_csphalo.F90 b/base/tools/psb_csphalo.F90 index 79b2b5b7..8731c093 100644 --- a/base/tools/psb_csphalo.F90 +++ b/base/tools/psb_csphalo.F90 @@ -90,7 +90,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, & & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& @@ -125,10 +126,10 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -329,14 +330,14 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & acoo%val,iarcv,jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv,rvsz,brvindx,ictxt,info) + & iarcv,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv,rvsz,brvindx,ictxt,info) + & jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) @@ -425,14 +426,14 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) @@ -530,7 +531,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -557,7 +558,8 @@ Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& & data_,totxch,nxs, nxr, ncg @@ -586,10 +588,10 @@ Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -772,14 +774,14 @@ Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& @@ -874,7 +876,7 @@ Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -900,7 +902,8 @@ Subroutine psb_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,nxs, nxr, err_act, nsnds, nrcvs @@ -930,10 +933,10 @@ Subroutine psb_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1128,14 +1131,14 @@ Subroutine psb_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) @@ -1234,7 +1237,7 @@ Subroutine psb_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -1260,7 +1263,8 @@ Subroutine psb_c_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,ngtz, idx, nxs, nxr, err_act, & @@ -1292,10 +1296,10 @@ Subroutine psb_c_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1500,14 +1504,14 @@ Subroutine psb_c_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,liasnd,ljasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(liasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(ljasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) @@ -1606,7 +1610,7 @@ Subroutine psb_c_lc_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index c2a52eb3..15ea556f 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -64,7 +64,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -75,8 +76,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_cspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -185,7 +186,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -208,7 +209,8 @@ subroutine psb_cspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -219,8 +221,8 @@ subroutine psb_cspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) name = 'psb_cspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -282,7 +284,7 @@ subroutine psb_cspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +308,8 @@ subroutine psb_cspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -317,8 +320,8 @@ subroutine psb_cspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) name = 'psb_cspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -380,7 +383,7 @@ subroutine psb_cspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -403,7 +406,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) @@ -424,8 +428,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) goto 9999 end if - ictxt = desc_ar%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_ar%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -495,7 +499,7 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -518,7 +522,8 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -530,8 +535,8 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_cspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -646,7 +651,7 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_csprn.f90 b/base/tools/psb_csprn.f90 index 3912cdae..82fb5be2 100644 --- a/base/tools/psb_csprn.f90 +++ b/base/tools/psb_csprn.f90 @@ -53,7 +53,8 @@ Subroutine psb_csprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name logical :: clear_ @@ -64,8 +65,8 @@ Subroutine psb_csprn(a, desc_a,info,clear) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': start ' @@ -88,7 +89,7 @@ Subroutine psb_csprn(a, desc_a,info,clear) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_d_glob_transpose.F90 b/base/tools/psb_d_glob_transpose.F90 index 638ba174..caf99400 100644 --- a/base/tools/psb_d_glob_transpose.F90 +++ b/base/tools/psb_d_glob_transpose.F90 @@ -110,7 +110,8 @@ subroutine psb_ld_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) integer(psb_ipk_), intent(out) :: info ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_lpk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzt, nzd @@ -137,10 +138,10 @@ subroutine psb_ld_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -287,14 +288,14 @@ subroutine psb_ld_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),acoo%ia(nzl+1:nzl+iszr),& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& @@ -385,7 +386,7 @@ subroutine psb_ld_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ld_coo_glob_transpose @@ -406,7 +407,8 @@ subroutine psb_d_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) type(psb_desc_type), intent(out), optional :: desc_rx integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_ipk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzd @@ -434,10 +436,10 @@ subroutine psb_d_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -586,14 +588,14 @@ subroutine psb_d_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),iarcv(1:iszr),& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv(1:iszr),rvsz,brvindx,ictxt,info) + & iarcv(1:iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& @@ -690,7 +692,7 @@ subroutine psb_d_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_d_coo_glob_transpose @@ -709,19 +711,20 @@ subroutine psb_d_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_d_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -760,19 +763,20 @@ subroutine psb_d_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_d_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -811,19 +815,20 @@ subroutine psb_ld_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_ld_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -862,19 +867,20 @@ subroutine psb_ld_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_ld_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if diff --git a/base/tools/psb_d_map.f90 b/base/tools/psb_d_map.f90 index 51672121..9fdebb4d 100644 --- a/base/tools/psb_d_map.f90 +++ b/base/tools/psb_d_map.f90 @@ -51,7 +51,8 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work) ! real(psb_dpk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V' info = psb_success_ @@ -66,14 +67,14 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() + ctxt = map%p_desc_V%get_context() nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_U2V,x,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info) if (info /= psb_success_) then @@ -83,7 +84,7 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() + ctxt = map%desc_V%get_context() nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -93,7 +94,7 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_U2V,xt,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info) if (info /= psb_success_) then @@ -125,7 +126,8 @@ subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_d_vect_type),pointer :: ptx, pty real(psb_dpk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V_v' info = psb_success_ @@ -140,8 +142,8 @@ subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_V%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() if (present(vty)) then @@ -154,7 +156,7 @@ subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(done,map%mat_U2V,x,dzero,pty,info) if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info) @@ -167,8 +169,8 @@ subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_V%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -188,7 +190,7 @@ subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(done,map%mat_U2V,ptx,dzero,pty,info) if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info) @@ -232,7 +234,8 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work) ! real(psb_dpk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U' info = psb_success_ @@ -247,14 +250,14 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() + ctxt = map%p_desc_U%get_context() nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_V2U,x,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_U,info) if (info /= psb_success_) then @@ -264,7 +267,7 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() + ctxt = map%desc_U%get_context() nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -274,7 +277,7 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_V2U,xt,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_U,info) if (info /= psb_success_) then @@ -305,7 +308,8 @@ subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_d_vect_type),pointer :: ptx, pty real(psb_dpk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U_v' info = psb_success_ @@ -320,8 +324,8 @@ subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_U%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() if (present(vty)) then @@ -334,7 +338,7 @@ subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(done,map%mat_V2U,x,dzero,pty,info) if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info) @@ -347,8 +351,8 @@ subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_U%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -369,7 +373,7 @@ subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(done,map%mat_V2U,ptx,dzero,pty,info) if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info) diff --git a/base/tools/psb_d_par_csr_spspmm.f90 b/base/tools/psb_d_par_csr_spspmm.f90 index 2e34a32c..f9d110f7 100644 --- a/base/tools/psb_d_par_csr_spspmm.f90 +++ b/base/tools/psb_d_par_csr_spspmm.f90 @@ -73,7 +73,8 @@ Subroutine psb_d_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: ncol, nnz type(psb_ld_csr_sparse_mat) :: ltcsr type(psb_d_csr_sparse_mat) :: tcsr @@ -91,9 +92,9 @@ Subroutine psb_d_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -150,7 +151,7 @@ Subroutine psb_d_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -168,7 +169,8 @@ Subroutine psb_ld_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_lpk_) :: nacol, nccol, nnz type(psb_ld_csr_sparse_mat) :: tcsr1 logical :: update_desc_c @@ -185,9 +187,9 @@ Subroutine psb_ld_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -244,7 +246,7 @@ Subroutine psb_ld_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_d_remap.F90 b/base/tools/psb_d_remap.F90 new file mode 100644 index 00000000..2157b56b --- /dev/null +++ b/base/tools/psb_d_remap.F90 @@ -0,0 +1,255 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! +! +! Subroutine: psb_d_remap +! +! Arguments: +! desc_in - type(psb_desc_type). The communication descriptor to be cloned. +! desc_out - type(psb_desc_type). The output communication descriptor. +! info - integer. Return code. +subroutine psb_d_remap(np_remap, desc_in, a_in, ipd, isrc, nrsrc, naggr, & + & desc_out, a_out, info) + + use psb_base_mod, psb_protect_name => psb_d_remap + + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_dspmat_type), intent(inout) :: a_in + type(psb_dspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + + + ! locals + type(psb_ctxt_type) :: ctxt, newctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_) :: rnp, rme + integer(psb_ipk_) :: ipdest, id1, id2, imd, i, nsrc + integer(psb_ipk_), allocatable :: newnl(:), nzsrc(:), ids(:) + type(psb_ld_coo_sparse_mat) :: acoo_snd, acoo_rcv + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cdcpy' + + ctxt = desc_in%get_context() + + ! check on blacs grid + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Entered' + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + +!!$ write(0,*) ' Remapping from ',np,' onto ', np_remap + + if (desc_in%get_fmt() == 'BLOCK') then + ! + ! Should we spread the processes in the new context, + ! or should we keep them close? + ! + if (.true.) then + allocate(ids(0:np_remap-1)) + if (np_remap <= np/2) then + ids(0) = 0 + do ipdest=1,np_remap -1 + ids(ipdest) = ids(ipdest-1) + np/np_remap + end do +!!$ write(0,*) ' IDS ',ids(:) + else + do ipdest = 0, np_remap-1 + ids(ipdest) = ipdest + end do + end if + call psb_init(newctxt,np=np_remap,basectxt=ctxt,ids=ids) + else + call psb_init(newctxt,np=np_remap,basectxt=ctxt) + end if + + call psb_info(newctxt,rme,rnp) +!!$ write(0,*) 'Old context: ',me,np,' New context: ',rme,rnp + call psb_bcast(ctxt,rnp) + allocate(newnl(rnp),naggr(np),stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (rnp >= np) then + write(0,*) ' No remapping on larger proc count now' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + naggr = 0 + + ! + ! Compute destination for my data. + ! Simplistic reallocation: divide the NP processes + ! across the new ones (as balanced as possible), + ! then send all data from old to new process + ! + id2 = np/rnp + id1 = id2+1 + imd = mod(np,rnp) + if (me < (imd*id1)) then + ipdest = (me/id1) + else + ipdest = ( ((me-imd*id1)/id2) + imd) + end if + if (allocated(ids)) then + ipd = ids(ipdest) + else + ipd = ipdest + end if +!!$ write(0,*) ' Sending my data from ',me,' to ', & +!!$ & ipd, 'out of ',rnp,rnp-1 + + ! + ! Compute local rows for all new + ! processes; will have a BLOCK distribution + ! + newnl = 0 + newnl(ipdest+1) = desc_in%get_local_rows() + call psb_sum(ctxt,newnl) + + if (rme>=0) then + ! + if (rme < imd) then + isrc = [ (i, i=rme*id1,min(rme*id1+id1-1,np-1)) ] + else + isrc = [ (i, i= imd*id1+((rme-imd))*id2,& + & min(imd*id1+(rme-imd)*id2+id2-1,np-1) ) ] + end if +!!$ write(0,*) me,rme,imd,' ISRC: ',isrc(:) + nsrc = size(isrc) +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',desc_out%get_local_rows(),desc_out%get_global_rows() + else +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',0,0 + end if + else + write(0,*) 'Right now only BLOCK on input ' + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Collect matrices on their destinations + ! + block + integer(psb_ipk_) :: nzsnd, nzrcv, ip + integer(psb_ipk_) :: nrl, ncl, nzl, nzp + call a_in%cp_to(acoo_snd) + nzsnd = acoo_snd%get_nzeros() + call psb_snd(ctxt,nzsnd,ipd) + call psb_snd(ctxt,desc_in%get_local_rows(),ipd) + ! Convert to global numbering + call psb_loc_to_glob(acoo_snd%ia(1:nzsnd),desc_in,info) + call psb_loc_to_glob(acoo_snd%ja(1:nzsnd),desc_in,info) + + call psb_snd(ctxt,acoo_snd%ia(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%ja(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%val(1:nzsnd),ipd) + + if (rme>=0) then + ! prepare to receive + nzsrc = isrc + nrsrc = isrc + nzl = 0 + do ip=1, nsrc + call psb_rcv(ctxt,nzsrc(ip),isrc(ip)) + call psb_rcv(ctxt,nrsrc(ip),isrc(ip)) + nzl = nzl + nzsrc(ip) + end do +!!$ write(0,*) rme,' Check on NR:',newnl(rme+1),sum(nrsrc) + call acoo_rcv%allocate(newnl(rme+1),newnl(rme+1),nzl) + nrl = acoo_rcv%get_nrows() + ncl = acoo_rcv%get_ncols() + nzp = 0 + do ip=1, nsrc + call psb_rcv(ctxt,acoo_rcv%ia(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%ja(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%val(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + nzp = nzp + nzsrc(ip) + end do + call acoo_rcv%set_nzeros(nzp) +!!$ write(0,*) rme,' Collected: ',& +!!$ & acoo_rcv%get_nrows(),acoo_rcv%get_ncols(),acoo_rcv%get_nzeros() + + ! + ! New descriptor + ! + call psb_cdall(newctxt,desc_out,info,nl=newnl(rme+1)) + ! Insert + call psb_spall(a_out,desc_out,info) + call psb_spins(nzp,acoo_rcv%ia(1:nzp),acoo_rcv%ja(1:nzp),& + & acoo_rcv%val(1:nzp),a_out,desc_out,info) + ! Assemble + call psb_cdasb(desc_out,info) + call psb_spasb(a_out,desc_out,info) + +!!$ write(0,*) rme,' Regenerated: ',& +!!$ & desc_out%get_local_rows(), desc_out%get_local_cols(),& +!!$ & a_out%get_nrows(),a_out%get_ncols(),a_out%get_nzeros() + naggr(me+1) = desc_out%get_local_rows() + else + naggr(me+1) = 0 + end if + call psb_sum(ctxt,naggr) + + end block + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_d_remap diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 73611ad7..7989929b 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -52,7 +52,7 @@ subroutine psb_dalloc_vect(x, desc_a,info) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -63,9 +63,9 @@ subroutine psb_dalloc_vect(x, desc_a,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -105,7 +105,7 @@ subroutine psb_dalloc_vect(x, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -133,8 +133,9 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) integer(psb_ipk_), optional, intent(in) :: n,lb !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -145,9 +146,9 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -176,9 +177,9 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -216,7 +217,7 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -235,8 +236,9 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) integer(psb_ipk_), optional, intent(in) :: n !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -247,9 +249,9 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -273,9 +275,9 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -308,7 +310,7 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dallc_a.f90 b/base/tools/psb_dallc_a.f90 index b9fcf114..8cd927fe 100644 --- a/base/tools/psb_dallc_a.f90 +++ b/base/tools/psb_dallc_a.f90 @@ -55,7 +55,8 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) !locals integer(psb_ipk_) :: err,nr,i,j,n_,err_act - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: exch(3) character(len=20) :: name @@ -67,9 +68,9 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -91,9 +92,9 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -124,7 +125,7 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_dallocv(x, desc_a,info,n) !locals integer(psb_ipk_) :: nr,i,err_act - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -196,9 +198,9 @@ subroutine psb_dallocv(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -238,7 +240,7 @@ subroutine psb_dallocv(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index 1d141cdf..fac4198d 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -62,7 +62,8 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -73,13 +74,13 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) name = 'psb_dgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -117,7 +118,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -135,7 +136,8 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me, i, n + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, i, n integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -146,13 +148,13 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) name = 'psb_dgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -198,7 +200,7 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -217,7 +219,8 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ @@ -229,7 +232,7 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) name = 'psb_dgeasb' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -246,7 +249,7 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) end if endif - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -286,7 +289,7 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dasb_a.f90 b/base/tools/psb_dasb_a.f90 index 42a60fbf..2a62fedf 100644 --- a/base/tools/psb_dasb_a.f90 +++ b/base/tools/psb_dasb_a.f90 @@ -52,7 +52,8 @@ subroutine psb_dasb(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,nrow,ncol, err_act integer(psb_ipk_) :: i1sz, i2sz integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -74,9 +75,9 @@ subroutine psb_dasb(x, desc_a, info, scratch) call psb_errpush(info,name) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & @@ -96,7 +97,7 @@ subroutine psb_dasb(x, desc_a, info, scratch) endif ! check size - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() i1sz = size(x,dim=1) @@ -129,7 +130,7 @@ subroutine psb_dasb(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -188,7 +189,8 @@ subroutine psb_dasbv(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -201,13 +203,13 @@ subroutine psb_dasbv(x, desc_a, info, scratch) info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -252,7 +254,7 @@ subroutine psb_dasbv(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dcdbldext.F90 b/base/tools/psb_dcdbldext.F90 index 771e746f..fdafb500 100644 --- a/base/tools/psb_dcdbldext.F90 +++ b/base/tools/psb_dcdbldext.F90 @@ -90,7 +90,9 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ integer(psb_lpk_) :: gidx, lnz - integer(psb_mpk_) :: icomm, ictxt, me, np, minfo + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_mpk_) :: icomm, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -114,9 +116,9 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) If (debug_level >= psb_debug_outer_) & & Write(debug_unit,*) me,' ',trim(name),& @@ -187,7 +189,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif ! ! Ok, since we are only estimating, do it as follows: @@ -215,7 +217,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_) then Write(debug_unit,*) me,' ',trim(name),':Start',& & lworks,lworkr, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif @@ -593,7 +595,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_move_alloc(t_halo_out,halo,info) ! @@ -672,7 +674,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),': converting indexes' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) @@ -701,7 +703,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 6c36dd09..8e092dfa 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -46,7 +46,8 @@ subroutine psb_dfree_vect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -60,9 +61,9 @@ subroutine psb_dfree_vect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -86,7 +87,7 @@ subroutine psb_dfree_vect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -100,7 +101,8 @@ subroutine psb_dfree_vect_r2(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act, i + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act, i character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psb_dfree_vect_r2(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +139,7 @@ subroutine psb_dfree_vect_r2(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -152,7 +154,8 @@ subroutine psb_dfree_multivect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -166,9 +169,9 @@ subroutine psb_dfree_multivect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +195,7 @@ subroutine psb_dfree_multivect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dfree_a.f90 b/base/tools/psb_dfree_a.f90 index a33c41be..0ce49ecc 100644 --- a/base/tools/psb_dfree_a.f90 +++ b/base/tools/psb_dfree_a.f90 @@ -48,7 +48,8 @@ subroutine psb_dfree(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_dfree' @@ -64,9 +65,9 @@ subroutine psb_dfree(x, desc_a, info) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -92,7 +93,7 @@ subroutine psb_dfree(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -116,7 +117,8 @@ subroutine psb_dfreev(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_dfreev' @@ -131,9 +133,9 @@ subroutine psb_dfreev(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -157,7 +159,7 @@ subroutine psb_dfreev(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dgetelem.f90 b/base/tools/psb_dgetelem.f90 index 0611221e..8f5247c7 100644 --- a/base/tools/psb_dgetelem.f90 +++ b/base/tools/psb_dgetelem.f90 @@ -55,7 +55,8 @@ function psb_d_getelem(x,index,desc_a,info) result(res) !locals integer(psb_ipk_) :: localindex(1) - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_lpk_) :: gindex(1) integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) character(len=20) :: name @@ -74,9 +75,9 @@ function psb_d_getelem(x,index,desc_a,info) result(res) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -95,7 +96,7 @@ function psb_d_getelem(x,index,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index ad7f8d90..3e873ded 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -63,7 +63,8 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -79,9 +80,9 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -145,7 +146,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -190,7 +191,8 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) real(psb_dpk_), allocatable :: lval(:) logical :: local_ @@ -207,9 +209,9 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -267,7 +269,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -295,7 +297,8 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -311,9 +314,9 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -381,7 +384,7 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -425,9 +429,9 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -491,7 +495,7 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dins_a.f90 b/base/tools/psb_dins_a.f90 index 9aee33bd..eb04ebaf 100644 --- a/base/tools/psb_dins_a.f90 +++ b/base/tools/psb_dins_a.f90 @@ -68,7 +68,8 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -86,9 +87,9 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -169,7 +170,7 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -248,7 +249,8 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me,dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -266,9 +268,9 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -359,7 +361,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dspalloc.f90 b/base/tools/psb_dspalloc.f90 index 9ae4572a..56ad6c93 100644 --- a/base/tools/psb_dspalloc.f90 +++ b/base/tools/psb_dspalloc.f90 @@ -52,7 +52,8 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit @@ -67,10 +68,10 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() dectype = desc_a%get_dectype() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -101,7 +102,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=nnz_) + call a%allocate(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='sp_all') @@ -117,7 +118,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index 542e6901..457553f7 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -62,7 +62,8 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_d_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -73,12 +74,12 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() ! check on BLACS grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +138,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dspfree.f90 b/base/tools/psb_dspfree.f90 index ee8388ce..06004348 100644 --- a/base/tools/psb_dspfree.f90 +++ b/base/tools/psb_dspfree.f90 @@ -48,7 +48,8 @@ subroutine psb_dspfree(a, desc_a,info) type(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act character(len=20) :: name info=psb_success_ @@ -63,7 +64,7 @@ subroutine psb_dspfree(a, desc_a,info) call psb_errpush(info,name) return else - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() end if !...deallocate a.... @@ -72,7 +73,7 @@ subroutine psb_dspfree(a, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dsphalo.F90 b/base/tools/psb_dsphalo.F90 index 24949cff..e8a59e52 100644 --- a/base/tools/psb_dsphalo.F90 +++ b/base/tools/psb_dsphalo.F90 @@ -90,7 +90,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, & & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& @@ -125,10 +126,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -329,14 +330,14 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & acoo%val,iarcv,jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv,rvsz,brvindx,ictxt,info) + & iarcv,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv,rvsz,brvindx,ictxt,info) + & jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) @@ -425,14 +426,14 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) @@ -530,7 +531,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -557,7 +558,8 @@ Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& & data_,totxch,nxs, nxr, ncg @@ -586,10 +588,10 @@ Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -772,14 +774,14 @@ Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& @@ -874,7 +876,7 @@ Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -900,7 +902,8 @@ Subroutine psb_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,nxs, nxr, err_act, nsnds, nrcvs @@ -930,10 +933,10 @@ Subroutine psb_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1128,14 +1131,14 @@ Subroutine psb_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) @@ -1234,7 +1237,7 @@ Subroutine psb_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -1260,7 +1263,8 @@ Subroutine psb_d_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,ngtz, idx, nxs, nxr, err_act, & @@ -1292,10 +1296,10 @@ Subroutine psb_d_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1500,14 +1504,14 @@ Subroutine psb_d_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,liasnd,ljasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(liasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(ljasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) @@ -1606,7 +1610,7 @@ Subroutine psb_d_ld_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index 4018a36a..3e9ef0cc 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -64,7 +64,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -75,8 +76,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_dspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -185,7 +186,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -208,7 +209,8 @@ subroutine psb_dspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -219,8 +221,8 @@ subroutine psb_dspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) name = 'psb_dspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -282,7 +284,7 @@ subroutine psb_dspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +308,8 @@ subroutine psb_dspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -317,8 +320,8 @@ subroutine psb_dspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) name = 'psb_dspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -380,7 +383,7 @@ subroutine psb_dspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -403,7 +406,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) @@ -424,8 +428,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) goto 9999 end if - ictxt = desc_ar%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_ar%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -495,7 +499,7 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -518,7 +522,8 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -530,8 +535,8 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_dspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -646,7 +651,7 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_dsprn.f90 b/base/tools/psb_dsprn.f90 index c5f81e48..36e0531f 100644 --- a/base/tools/psb_dsprn.f90 +++ b/base/tools/psb_dsprn.f90 @@ -53,7 +53,8 @@ Subroutine psb_dsprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name logical :: clear_ @@ -64,8 +65,8 @@ Subroutine psb_dsprn(a, desc_a,info,clear) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': start ' @@ -88,7 +89,7 @@ Subroutine psb_dsprn(a, desc_a,info,clear) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_eallc_a.f90 b/base/tools/psb_eallc_a.f90 index 5f6e3c36..c9c65634 100644 --- a/base/tools/psb_eallc_a.f90 +++ b/base/tools/psb_eallc_a.f90 @@ -55,7 +55,8 @@ subroutine psb_ealloc(x, desc_a, info, n, lb) !locals integer(psb_ipk_) :: err,nr,i,j,n_,err_act - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: exch(3) character(len=20) :: name @@ -67,9 +68,9 @@ subroutine psb_ealloc(x, desc_a, info, n, lb) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -91,9 +92,9 @@ subroutine psb_ealloc(x, desc_a, info, n, lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -124,7 +125,7 @@ subroutine psb_ealloc(x, desc_a, info, n, lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_eallocv(x, desc_a,info,n) !locals integer(psb_ipk_) :: nr,i,err_act - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -196,9 +198,9 @@ subroutine psb_eallocv(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -238,7 +240,7 @@ subroutine psb_eallocv(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_easb_a.f90 b/base/tools/psb_easb_a.f90 index 5c62aa59..baa8514d 100644 --- a/base/tools/psb_easb_a.f90 +++ b/base/tools/psb_easb_a.f90 @@ -52,7 +52,8 @@ subroutine psb_easb(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,nrow,ncol, err_act integer(psb_ipk_) :: i1sz, i2sz integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -74,9 +75,9 @@ subroutine psb_easb(x, desc_a, info, scratch) call psb_errpush(info,name) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & @@ -96,7 +97,7 @@ subroutine psb_easb(x, desc_a, info, scratch) endif ! check size - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() i1sz = size(x,dim=1) @@ -129,7 +130,7 @@ subroutine psb_easb(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -188,7 +189,8 @@ subroutine psb_easbv(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -201,13 +203,13 @@ subroutine psb_easbv(x, desc_a, info, scratch) info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -252,7 +254,7 @@ subroutine psb_easbv(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_efree_a.f90 b/base/tools/psb_efree_a.f90 index c07ee694..85baa0c0 100644 --- a/base/tools/psb_efree_a.f90 +++ b/base/tools/psb_efree_a.f90 @@ -48,7 +48,8 @@ subroutine psb_efree(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_efree' @@ -64,9 +65,9 @@ subroutine psb_efree(x, desc_a, info) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -92,7 +93,7 @@ subroutine psb_efree(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -116,7 +117,8 @@ subroutine psb_efreev(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_efreev' @@ -131,9 +133,9 @@ subroutine psb_efreev(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -157,7 +159,7 @@ subroutine psb_efreev(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_eins_a.f90 b/base/tools/psb_eins_a.f90 index 3923a265..25744f5a 100644 --- a/base/tools/psb_eins_a.f90 +++ b/base/tools/psb_eins_a.f90 @@ -68,7 +68,8 @@ subroutine psb_einsvi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -86,9 +87,9 @@ subroutine psb_einsvi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -169,7 +170,7 @@ subroutine psb_einsvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -248,7 +249,8 @@ subroutine psb_einsi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me,dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -266,9 +268,9 @@ subroutine psb_einsi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -359,7 +361,7 @@ subroutine psb_einsi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_get_overlap.f90 b/base/tools/psb_get_overlap.f90 index 9563754f..9ef3377e 100644 --- a/base/tools/psb_get_overlap.f90 +++ b/base/tools/psb_get_overlap.f90 @@ -47,7 +47,7 @@ subroutine psb_get_ovrlap(ovrel,desc,info) implicit none integer(psb_ipk_), allocatable, intent(out) :: ovrel(:) type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i,j, err_act character(len=20) :: name @@ -56,7 +56,7 @@ subroutine psb_get_ovrlap(ovrel,desc,info) name='psi_get_overlap' call psb_erractionsave(err_act) - if (.not.psb_is_asb_desc(desc)) then + if (.not.desc%is_asb()) then info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_glob_to_loc.f90 b/base/tools/psb_glob_to_loc.f90 index 79799d19..5681d2ae 100644 --- a/base/tools/psb_glob_to_loc.f90 +++ b/base/tools/psb_glob_to_loc.f90 @@ -59,7 +59,8 @@ subroutine psb_glob_to_loc2v(x,y,desc_a,info,iact,owned) logical, intent(in), optional :: owned !....locals.... - integer(psb_ipk_) :: n, ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: n, iam, np character :: act integer(psb_ipk_) :: err_act character(len=20) :: name @@ -74,8 +75,8 @@ subroutine psb_glob_to_loc2v(x,y,desc_a,info,iact,owned) goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt,iam,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,iam,np) if (present(iact)) then @@ -113,7 +114,7 @@ subroutine psb_glob_to_loc2v(x,y,desc_a,info,iact,owned) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned) character :: act integer(psb_ipk_) :: err_act character(len=20) :: name - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np if(psb_get_errstatus() /= 0) return info=psb_success_ @@ -196,8 +198,8 @@ subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned) goto 9999 end if - ictxt = desc_a%get_context() - call psb_info(ictxt,iam,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,iam,np) if (present(iact)) then @@ -229,7 +231,7 @@ subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_i2allc_a.f90 b/base/tools/psb_i2allc_a.f90 index 3d453ea8..52598304 100644 --- a/base/tools/psb_i2allc_a.f90 +++ b/base/tools/psb_i2allc_a.f90 @@ -55,7 +55,8 @@ subroutine psb_i2alloc(x, desc_a, info, n, lb) !locals integer(psb_ipk_) :: err,nr,i,j,n_,err_act - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: exch(3) character(len=20) :: name @@ -67,9 +68,9 @@ subroutine psb_i2alloc(x, desc_a, info, n, lb) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -91,9 +92,9 @@ subroutine psb_i2alloc(x, desc_a, info, n, lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -124,7 +125,7 @@ subroutine psb_i2alloc(x, desc_a, info, n, lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_i2allocv(x, desc_a,info,n) !locals integer(psb_ipk_) :: nr,i,err_act - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -196,9 +198,9 @@ subroutine psb_i2allocv(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -238,7 +240,7 @@ subroutine psb_i2allocv(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_i2asb_a.f90 b/base/tools/psb_i2asb_a.f90 index 4e7cc9b0..97879105 100644 --- a/base/tools/psb_i2asb_a.f90 +++ b/base/tools/psb_i2asb_a.f90 @@ -52,7 +52,8 @@ subroutine psb_i2asb(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,nrow,ncol, err_act integer(psb_ipk_) :: i1sz, i2sz integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -74,9 +75,9 @@ subroutine psb_i2asb(x, desc_a, info, scratch) call psb_errpush(info,name) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & @@ -96,7 +97,7 @@ subroutine psb_i2asb(x, desc_a, info, scratch) endif ! check size - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() i1sz = size(x,dim=1) @@ -129,7 +130,7 @@ subroutine psb_i2asb(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -188,7 +189,8 @@ subroutine psb_i2asbv(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -201,13 +203,13 @@ subroutine psb_i2asbv(x, desc_a, info, scratch) info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -252,7 +254,7 @@ subroutine psb_i2asbv(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_i2free_a.f90 b/base/tools/psb_i2free_a.f90 index 5e673626..d5c7509c 100644 --- a/base/tools/psb_i2free_a.f90 +++ b/base/tools/psb_i2free_a.f90 @@ -48,7 +48,8 @@ subroutine psb_i2free(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_i2free' @@ -64,9 +65,9 @@ subroutine psb_i2free(x, desc_a, info) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -92,7 +93,7 @@ subroutine psb_i2free(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -116,7 +117,8 @@ subroutine psb_i2freev(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_i2freev' @@ -131,9 +133,9 @@ subroutine psb_i2freev(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -157,7 +159,7 @@ subroutine psb_i2freev(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_i2ins_a.f90 b/base/tools/psb_i2ins_a.f90 index 76d7c260..975e619b 100644 --- a/base/tools/psb_i2ins_a.f90 +++ b/base/tools/psb_i2ins_a.f90 @@ -68,7 +68,8 @@ subroutine psb_i2insvi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -86,9 +87,9 @@ subroutine psb_i2insvi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -169,7 +170,7 @@ subroutine psb_i2insvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -248,7 +249,8 @@ subroutine psb_i2insi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me,dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -266,9 +268,9 @@ subroutine psb_i2insi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -359,7 +361,7 @@ subroutine psb_i2insi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index 65f5f1da..ac4ee840 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -52,7 +52,7 @@ subroutine psb_ialloc_vect(x, desc_a,info) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -63,9 +63,9 @@ subroutine psb_ialloc_vect(x, desc_a,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -105,7 +105,7 @@ subroutine psb_ialloc_vect(x, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -133,8 +133,9 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) integer(psb_ipk_), optional, intent(in) :: n,lb !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -145,9 +146,9 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -176,9 +177,9 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -216,7 +217,7 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -235,8 +236,9 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) integer(psb_ipk_), optional, intent(in) :: n !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -247,9 +249,9 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -273,9 +275,9 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -308,7 +310,7 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 52fbe165..d296d2f9 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -62,7 +62,8 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -73,13 +74,13 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) name = 'psb_igeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -117,7 +118,7 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -135,7 +136,8 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me, i, n + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, i, n integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -146,13 +148,13 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) name = 'psb_igeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -198,7 +200,7 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -217,7 +219,8 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ @@ -229,7 +232,7 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) name = 'psb_igeasb' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -246,7 +249,7 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) end if endif - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -286,7 +289,7 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index b68485ee..31d92133 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -63,7 +63,9 @@ subroutine psb_icdasb(desc,info,ext_hv,mold) integer(psb_ipk_),allocatable :: ovrlap_index(:),halo_index(:), ext_index(:) integer(psb_ipk_) :: i, n_col, dectype, err_act, n_row - integer(psb_mpk_) :: np,me, icomm, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np,me logical :: ext_hv_ logical, parameter :: do_timings=.true. integer(psb_ipk_), save :: idx_phase1=-1, idx_phase2=-1, idx_phase3=-1 @@ -80,7 +82,7 @@ subroutine psb_icdasb(desc,info,ext_hv,mold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc%get_context() + ctxt = desc%get_context() dectype = desc%get_dectype() n_row = desc%get_local_rows() n_col = desc%get_local_cols() @@ -102,7 +104,7 @@ subroutine psb_icdasb(desc,info,ext_hv,mold) call psb_tic(idx_total) ! check on blacs grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -191,7 +193,7 @@ subroutine psb_icdasb(desc,info,ext_hv,mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index 516f1219..a804913a 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -46,7 +46,8 @@ subroutine psb_ifree_vect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -60,9 +61,9 @@ subroutine psb_ifree_vect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -86,7 +87,7 @@ subroutine psb_ifree_vect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -100,7 +101,8 @@ subroutine psb_ifree_vect_r2(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act, i + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act, i character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psb_ifree_vect_r2(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +139,7 @@ subroutine psb_ifree_vect_r2(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -152,7 +154,8 @@ subroutine psb_ifree_multivect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -166,9 +169,9 @@ subroutine psb_ifree_multivect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +195,7 @@ subroutine psb_ifree_multivect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 48aa97fb..c9c0ed9b 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -63,7 +63,8 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -79,9 +80,9 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -145,7 +146,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -190,7 +191,8 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: lval(:) logical :: local_ @@ -207,9 +209,9 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -267,7 +269,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -295,7 +297,8 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -311,9 +314,9 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -381,7 +384,7 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -425,9 +429,9 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -491,7 +495,7 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 index e397f7cb..85fd67e7 100644 --- a/base/tools/psb_lallc.f90 +++ b/base/tools/psb_lallc.f90 @@ -52,7 +52,7 @@ subroutine psb_lalloc_vect(x, desc_a,info) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -63,9 +63,9 @@ subroutine psb_lalloc_vect(x, desc_a,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -105,7 +105,7 @@ subroutine psb_lalloc_vect(x, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -133,8 +133,9 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb) integer(psb_ipk_), optional, intent(in) :: n,lb !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -145,9 +146,9 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -176,9 +177,9 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -216,7 +217,7 @@ subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -235,8 +236,9 @@ subroutine psb_lalloc_multivect(x, desc_a,info,n) integer(psb_ipk_), optional, intent(in) :: n !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -247,9 +249,9 @@ subroutine psb_lalloc_multivect(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -273,9 +275,9 @@ subroutine psb_lalloc_multivect(x, desc_a,info,n) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -308,7 +310,7 @@ subroutine psb_lalloc_multivect(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_lasb.f90 b/base/tools/psb_lasb.f90 index c1835b05..8b80ae89 100644 --- a/base/tools/psb_lasb.f90 +++ b/base/tools/psb_lasb.f90 @@ -62,7 +62,8 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -73,13 +74,13 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) name = 'psb_lgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -117,7 +118,7 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -135,7 +136,8 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me, i, n + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, i, n integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -146,13 +148,13 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) name = 'psb_lgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -198,7 +200,7 @@ subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -217,7 +219,8 @@ subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ @@ -229,7 +232,7 @@ subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n) name = 'psb_lgeasb' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -246,7 +249,7 @@ subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n) end if endif - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -286,7 +289,7 @@ subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_lfree.f90 b/base/tools/psb_lfree.f90 index d6c597a8..6630601c 100644 --- a/base/tools/psb_lfree.f90 +++ b/base/tools/psb_lfree.f90 @@ -46,7 +46,8 @@ subroutine psb_lfree_vect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -60,9 +61,9 @@ subroutine psb_lfree_vect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -86,7 +87,7 @@ subroutine psb_lfree_vect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -100,7 +101,8 @@ subroutine psb_lfree_vect_r2(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act, i + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act, i character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psb_lfree_vect_r2(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +139,7 @@ subroutine psb_lfree_vect_r2(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -152,7 +154,8 @@ subroutine psb_lfree_multivect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -166,9 +169,9 @@ subroutine psb_lfree_multivect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +195,7 @@ subroutine psb_lfree_multivect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_lins.f90 b/base/tools/psb_lins.f90 index d7c044d1..42559a94 100644 --- a/base/tools/psb_lins.f90 +++ b/base/tools/psb_lins.f90 @@ -63,7 +63,8 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -79,9 +80,9 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -145,7 +146,7 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -190,7 +191,8 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) integer(psb_lpk_), allocatable :: lval(:) logical :: local_ @@ -207,9 +209,9 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -267,7 +269,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -295,7 +297,8 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -311,9 +314,9 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -381,7 +384,7 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -425,9 +429,9 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -491,7 +495,7 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_mallc_a.f90 b/base/tools/psb_mallc_a.f90 index 2bcedc5b..c815e8f9 100644 --- a/base/tools/psb_mallc_a.f90 +++ b/base/tools/psb_mallc_a.f90 @@ -55,7 +55,8 @@ subroutine psb_malloc(x, desc_a, info, n, lb) !locals integer(psb_ipk_) :: err,nr,i,j,n_,err_act - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: exch(3) character(len=20) :: name @@ -67,9 +68,9 @@ subroutine psb_malloc(x, desc_a, info, n, lb) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -91,9 +92,9 @@ subroutine psb_malloc(x, desc_a, info, n, lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -124,7 +125,7 @@ subroutine psb_malloc(x, desc_a, info, n, lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_mallocv(x, desc_a,info,n) !locals integer(psb_ipk_) :: nr,i,err_act - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -196,9 +198,9 @@ subroutine psb_mallocv(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -238,7 +240,7 @@ subroutine psb_mallocv(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_masb_a.f90 b/base/tools/psb_masb_a.f90 index 47c35d2a..50f2b768 100644 --- a/base/tools/psb_masb_a.f90 +++ b/base/tools/psb_masb_a.f90 @@ -52,7 +52,8 @@ subroutine psb_masb(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,nrow,ncol, err_act integer(psb_ipk_) :: i1sz, i2sz integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -74,9 +75,9 @@ subroutine psb_masb(x, desc_a, info, scratch) call psb_errpush(info,name) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & @@ -96,7 +97,7 @@ subroutine psb_masb(x, desc_a, info, scratch) endif ! check size - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() i1sz = size(x,dim=1) @@ -129,7 +130,7 @@ subroutine psb_masb(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -188,7 +189,8 @@ subroutine psb_masbv(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -201,13 +203,13 @@ subroutine psb_masbv(x, desc_a, info, scratch) info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -252,7 +254,7 @@ subroutine psb_masbv(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_mfree_a.f90 b/base/tools/psb_mfree_a.f90 index 49f255da..c2f57f21 100644 --- a/base/tools/psb_mfree_a.f90 +++ b/base/tools/psb_mfree_a.f90 @@ -48,7 +48,8 @@ subroutine psb_mfree(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_mfree' @@ -64,9 +65,9 @@ subroutine psb_mfree(x, desc_a, info) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -92,7 +93,7 @@ subroutine psb_mfree(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -116,7 +117,8 @@ subroutine psb_mfreev(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_mfreev' @@ -131,9 +133,9 @@ subroutine psb_mfreev(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -157,7 +159,7 @@ subroutine psb_mfreev(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_mins_a.f90 b/base/tools/psb_mins_a.f90 index 6d83b724..d1549c92 100644 --- a/base/tools/psb_mins_a.f90 +++ b/base/tools/psb_mins_a.f90 @@ -68,7 +68,8 @@ subroutine psb_minsvi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -86,9 +87,9 @@ subroutine psb_minsvi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -169,7 +170,7 @@ subroutine psb_minsvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -248,7 +249,8 @@ subroutine psb_minsi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me,dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -266,9 +268,9 @@ subroutine psb_minsi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -359,7 +361,7 @@ subroutine psb_minsi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_s_glob_transpose.F90 b/base/tools/psb_s_glob_transpose.F90 index 875f92db..c7dc818f 100644 --- a/base/tools/psb_s_glob_transpose.F90 +++ b/base/tools/psb_s_glob_transpose.F90 @@ -110,7 +110,8 @@ subroutine psb_ls_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) integer(psb_ipk_), intent(out) :: info ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_lpk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzt, nzd @@ -137,10 +138,10 @@ subroutine psb_ls_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -287,14 +288,14 @@ subroutine psb_ls_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),acoo%ia(nzl+1:nzl+iszr),& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& @@ -385,7 +386,7 @@ subroutine psb_ls_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_ls_coo_glob_transpose @@ -406,7 +407,8 @@ subroutine psb_s_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) type(psb_desc_type), intent(out), optional :: desc_rx integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_ipk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzd @@ -434,10 +436,10 @@ subroutine psb_s_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -586,14 +588,14 @@ subroutine psb_s_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),iarcv(1:iszr),& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv(1:iszr),rvsz,brvindx,ictxt,info) + & iarcv(1:iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& @@ -690,7 +692,7 @@ subroutine psb_s_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_s_coo_glob_transpose @@ -709,19 +711,20 @@ subroutine psb_s_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_s_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -760,19 +763,20 @@ subroutine psb_s_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_s_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -811,19 +815,20 @@ subroutine psb_ls_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_ls_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -862,19 +867,20 @@ subroutine psb_ls_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_ls_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if diff --git a/base/tools/psb_s_map.f90 b/base/tools/psb_s_map.f90 index 6fa9b7b7..6b6b09aa 100644 --- a/base/tools/psb_s_map.f90 +++ b/base/tools/psb_s_map.f90 @@ -51,7 +51,8 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work) ! real(psb_spk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V' info = psb_success_ @@ -66,14 +67,14 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() + ctxt = map%p_desc_V%get_context() nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,x,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info) if (info /= psb_success_) then @@ -83,7 +84,7 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() + ctxt = map%desc_V%get_context() nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -93,7 +94,7 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,xt,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info) if (info /= psb_success_) then @@ -125,7 +126,8 @@ subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_s_vect_type),pointer :: ptx, pty real(psb_spk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V_v' info = psb_success_ @@ -140,8 +142,8 @@ subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_V%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() if (present(vty)) then @@ -154,7 +156,7 @@ subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,x,szero,pty,info) if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info) @@ -167,8 +169,8 @@ subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_V%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -188,7 +190,7 @@ subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,ptx,szero,pty,info) if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info) @@ -232,7 +234,8 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work) ! real(psb_spk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U' info = psb_success_ @@ -247,14 +250,14 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() + ctxt = map%p_desc_U%get_context() nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,x,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_U,info) if (info /= psb_success_) then @@ -264,7 +267,7 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() + ctxt = map%desc_U%get_context() nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -274,7 +277,7 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,xt,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_U,info) if (info /= psb_success_) then @@ -305,7 +308,8 @@ subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_s_vect_type),pointer :: ptx, pty real(psb_spk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U_v' info = psb_success_ @@ -320,8 +324,8 @@ subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_U%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() if (present(vty)) then @@ -334,7 +338,7 @@ subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,x,szero,pty,info) if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info) @@ -347,8 +351,8 @@ subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_U%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -369,7 +373,7 @@ subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,ptx,szero,pty,info) if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info) diff --git a/base/tools/psb_s_par_csr_spspmm.f90 b/base/tools/psb_s_par_csr_spspmm.f90 index fba99f27..549aeba4 100644 --- a/base/tools/psb_s_par_csr_spspmm.f90 +++ b/base/tools/psb_s_par_csr_spspmm.f90 @@ -73,7 +73,8 @@ Subroutine psb_s_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: ncol, nnz type(psb_ls_csr_sparse_mat) :: ltcsr type(psb_s_csr_sparse_mat) :: tcsr @@ -91,9 +92,9 @@ Subroutine psb_s_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -150,7 +151,7 @@ Subroutine psb_s_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -168,7 +169,8 @@ Subroutine psb_ls_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_lpk_) :: nacol, nccol, nnz type(psb_ls_csr_sparse_mat) :: tcsr1 logical :: update_desc_c @@ -185,9 +187,9 @@ Subroutine psb_ls_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -244,7 +246,7 @@ Subroutine psb_ls_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_s_remap.F90 b/base/tools/psb_s_remap.F90 new file mode 100644 index 00000000..899c1b26 --- /dev/null +++ b/base/tools/psb_s_remap.F90 @@ -0,0 +1,255 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! +! +! Subroutine: psb_s_remap +! +! Arguments: +! desc_in - type(psb_desc_type). The communication descriptor to be cloned. +! desc_out - type(psb_desc_type). The output communication descriptor. +! info - integer. Return code. +subroutine psb_s_remap(np_remap, desc_in, a_in, ipd, isrc, nrsrc, naggr, & + & desc_out, a_out, info) + + use psb_base_mod, psb_protect_name => psb_s_remap + + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_sspmat_type), intent(inout) :: a_in + type(psb_sspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + + + ! locals + type(psb_ctxt_type) :: ctxt, newctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_) :: rnp, rme + integer(psb_ipk_) :: ipdest, id1, id2, imd, i, nsrc + integer(psb_ipk_), allocatable :: newnl(:), nzsrc(:), ids(:) + type(psb_ls_coo_sparse_mat) :: acoo_snd, acoo_rcv + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cdcpy' + + ctxt = desc_in%get_context() + + ! check on blacs grid + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Entered' + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + +!!$ write(0,*) ' Remapping from ',np,' onto ', np_remap + + if (desc_in%get_fmt() == 'BLOCK') then + ! + ! Should we spread the processes in the new context, + ! or should we keep them close? + ! + if (.true.) then + allocate(ids(0:np_remap-1)) + if (np_remap <= np/2) then + ids(0) = 0 + do ipdest=1,np_remap -1 + ids(ipdest) = ids(ipdest-1) + np/np_remap + end do +!!$ write(0,*) ' IDS ',ids(:) + else + do ipdest = 0, np_remap-1 + ids(ipdest) = ipdest + end do + end if + call psb_init(newctxt,np=np_remap,basectxt=ctxt,ids=ids) + else + call psb_init(newctxt,np=np_remap,basectxt=ctxt) + end if + + call psb_info(newctxt,rme,rnp) +!!$ write(0,*) 'Old context: ',me,np,' New context: ',rme,rnp + call psb_bcast(ctxt,rnp) + allocate(newnl(rnp),naggr(np),stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (rnp >= np) then + write(0,*) ' No remapping on larger proc count now' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + naggr = 0 + + ! + ! Compute destination for my data. + ! Simplistic reallocation: divide the NP processes + ! across the new ones (as balanced as possible), + ! then send all data from old to new process + ! + id2 = np/rnp + id1 = id2+1 + imd = mod(np,rnp) + if (me < (imd*id1)) then + ipdest = (me/id1) + else + ipdest = ( ((me-imd*id1)/id2) + imd) + end if + if (allocated(ids)) then + ipd = ids(ipdest) + else + ipd = ipdest + end if +!!$ write(0,*) ' Sending my data from ',me,' to ', & +!!$ & ipd, 'out of ',rnp,rnp-1 + + ! + ! Compute local rows for all new + ! processes; will have a BLOCK distribution + ! + newnl = 0 + newnl(ipdest+1) = desc_in%get_local_rows() + call psb_sum(ctxt,newnl) + + if (rme>=0) then + ! + if (rme < imd) then + isrc = [ (i, i=rme*id1,min(rme*id1+id1-1,np-1)) ] + else + isrc = [ (i, i= imd*id1+((rme-imd))*id2,& + & min(imd*id1+(rme-imd)*id2+id2-1,np-1) ) ] + end if +!!$ write(0,*) me,rme,imd,' ISRC: ',isrc(:) + nsrc = size(isrc) +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',desc_out%get_local_rows(),desc_out%get_global_rows() + else +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',0,0 + end if + else + write(0,*) 'Right now only BLOCK on input ' + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Collect matrices on their destinations + ! + block + integer(psb_ipk_) :: nzsnd, nzrcv, ip + integer(psb_ipk_) :: nrl, ncl, nzl, nzp + call a_in%cp_to(acoo_snd) + nzsnd = acoo_snd%get_nzeros() + call psb_snd(ctxt,nzsnd,ipd) + call psb_snd(ctxt,desc_in%get_local_rows(),ipd) + ! Convert to global numbering + call psb_loc_to_glob(acoo_snd%ia(1:nzsnd),desc_in,info) + call psb_loc_to_glob(acoo_snd%ja(1:nzsnd),desc_in,info) + + call psb_snd(ctxt,acoo_snd%ia(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%ja(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%val(1:nzsnd),ipd) + + if (rme>=0) then + ! prepare to receive + nzsrc = isrc + nrsrc = isrc + nzl = 0 + do ip=1, nsrc + call psb_rcv(ctxt,nzsrc(ip),isrc(ip)) + call psb_rcv(ctxt,nrsrc(ip),isrc(ip)) + nzl = nzl + nzsrc(ip) + end do +!!$ write(0,*) rme,' Check on NR:',newnl(rme+1),sum(nrsrc) + call acoo_rcv%allocate(newnl(rme+1),newnl(rme+1),nzl) + nrl = acoo_rcv%get_nrows() + ncl = acoo_rcv%get_ncols() + nzp = 0 + do ip=1, nsrc + call psb_rcv(ctxt,acoo_rcv%ia(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%ja(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%val(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + nzp = nzp + nzsrc(ip) + end do + call acoo_rcv%set_nzeros(nzp) +!!$ write(0,*) rme,' Collected: ',& +!!$ & acoo_rcv%get_nrows(),acoo_rcv%get_ncols(),acoo_rcv%get_nzeros() + + ! + ! New descriptor + ! + call psb_cdall(newctxt,desc_out,info,nl=newnl(rme+1)) + ! Insert + call psb_spall(a_out,desc_out,info) + call psb_spins(nzp,acoo_rcv%ia(1:nzp),acoo_rcv%ja(1:nzp),& + & acoo_rcv%val(1:nzp),a_out,desc_out,info) + ! Assemble + call psb_cdasb(desc_out,info) + call psb_spasb(a_out,desc_out,info) + +!!$ write(0,*) rme,' Regenerated: ',& +!!$ & desc_out%get_local_rows(), desc_out%get_local_cols(),& +!!$ & a_out%get_nrows(),a_out%get_ncols(),a_out%get_nzeros() + naggr(me+1) = desc_out%get_local_rows() + else + naggr(me+1) = 0 + end if + call psb_sum(ctxt,naggr) + + end block + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_s_remap diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 6e20f82e..941ce917 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -52,7 +52,7 @@ subroutine psb_salloc_vect(x, desc_a,info) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -63,9 +63,9 @@ subroutine psb_salloc_vect(x, desc_a,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -105,7 +105,7 @@ subroutine psb_salloc_vect(x, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -133,8 +133,9 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) integer(psb_ipk_), optional, intent(in) :: n,lb !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -145,9 +146,9 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -176,9 +177,9 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -216,7 +217,7 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -235,8 +236,9 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) integer(psb_ipk_), optional, intent(in) :: n !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -247,9 +249,9 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -273,9 +275,9 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -308,7 +310,7 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sallc_a.f90 b/base/tools/psb_sallc_a.f90 index 815acb61..3b511d61 100644 --- a/base/tools/psb_sallc_a.f90 +++ b/base/tools/psb_sallc_a.f90 @@ -55,7 +55,8 @@ subroutine psb_salloc(x, desc_a, info, n, lb) !locals integer(psb_ipk_) :: err,nr,i,j,n_,err_act - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: exch(3) character(len=20) :: name @@ -67,9 +68,9 @@ subroutine psb_salloc(x, desc_a, info, n, lb) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -91,9 +92,9 @@ subroutine psb_salloc(x, desc_a, info, n, lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -124,7 +125,7 @@ subroutine psb_salloc(x, desc_a, info, n, lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_sallocv(x, desc_a,info,n) !locals integer(psb_ipk_) :: nr,i,err_act - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -196,9 +198,9 @@ subroutine psb_sallocv(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -238,7 +240,7 @@ subroutine psb_sallocv(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 67d4ac92..c23ada14 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -62,7 +62,8 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -73,13 +74,13 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) name = 'psb_sgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -117,7 +118,7 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -135,7 +136,8 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me, i, n + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, i, n integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -146,13 +148,13 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) name = 'psb_sgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -198,7 +200,7 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -217,7 +219,8 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ @@ -229,7 +232,7 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) name = 'psb_sgeasb' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -246,7 +249,7 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) end if endif - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -286,7 +289,7 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sasb_a.f90 b/base/tools/psb_sasb_a.f90 index bef96be7..76dbdafb 100644 --- a/base/tools/psb_sasb_a.f90 +++ b/base/tools/psb_sasb_a.f90 @@ -52,7 +52,8 @@ subroutine psb_sasb(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,nrow,ncol, err_act integer(psb_ipk_) :: i1sz, i2sz integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -74,9 +75,9 @@ subroutine psb_sasb(x, desc_a, info, scratch) call psb_errpush(info,name) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & @@ -96,7 +97,7 @@ subroutine psb_sasb(x, desc_a, info, scratch) endif ! check size - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() i1sz = size(x,dim=1) @@ -129,7 +130,7 @@ subroutine psb_sasb(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -188,7 +189,8 @@ subroutine psb_sasbv(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -201,13 +203,13 @@ subroutine psb_sasbv(x, desc_a, info, scratch) info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -252,7 +254,7 @@ subroutine psb_sasbv(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_scdbldext.F90 b/base/tools/psb_scdbldext.F90 index 34047ded..40ac778f 100644 --- a/base/tools/psb_scdbldext.F90 +++ b/base/tools/psb_scdbldext.F90 @@ -90,7 +90,9 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ integer(psb_lpk_) :: gidx, lnz - integer(psb_mpk_) :: icomm, ictxt, me, np, minfo + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_mpk_) :: icomm, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -114,9 +116,9 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) If (debug_level >= psb_debug_outer_) & & Write(debug_unit,*) me,' ',trim(name),& @@ -187,7 +189,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif ! ! Ok, since we are only estimating, do it as follows: @@ -215,7 +217,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_) then Write(debug_unit,*) me,' ',trim(name),':Start',& & lworks,lworkr, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif @@ -593,7 +595,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_move_alloc(t_halo_out,halo,info) ! @@ -672,7 +674,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),': converting indexes' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) @@ -701,7 +703,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 index 34f03cae..add6162b 100644 --- a/base/tools/psb_sfree.f90 +++ b/base/tools/psb_sfree.f90 @@ -46,7 +46,8 @@ subroutine psb_sfree_vect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -60,9 +61,9 @@ subroutine psb_sfree_vect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -86,7 +87,7 @@ subroutine psb_sfree_vect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -100,7 +101,8 @@ subroutine psb_sfree_vect_r2(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act, i + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act, i character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psb_sfree_vect_r2(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +139,7 @@ subroutine psb_sfree_vect_r2(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -152,7 +154,8 @@ subroutine psb_sfree_multivect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -166,9 +169,9 @@ subroutine psb_sfree_multivect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +195,7 @@ subroutine psb_sfree_multivect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sfree_a.f90 b/base/tools/psb_sfree_a.f90 index 6d7412d0..036bb903 100644 --- a/base/tools/psb_sfree_a.f90 +++ b/base/tools/psb_sfree_a.f90 @@ -48,7 +48,8 @@ subroutine psb_sfree(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_sfree' @@ -64,9 +65,9 @@ subroutine psb_sfree(x, desc_a, info) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -92,7 +93,7 @@ subroutine psb_sfree(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -116,7 +117,8 @@ subroutine psb_sfreev(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_sfreev' @@ -131,9 +133,9 @@ subroutine psb_sfreev(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -157,7 +159,7 @@ subroutine psb_sfreev(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sgetelem.f90 b/base/tools/psb_sgetelem.f90 index 6a8f764e..244947b1 100644 --- a/base/tools/psb_sgetelem.f90 +++ b/base/tools/psb_sgetelem.f90 @@ -55,7 +55,8 @@ function psb_s_getelem(x,index,desc_a,info) result(res) !locals integer(psb_ipk_) :: localindex(1) - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_lpk_) :: gindex(1) integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) character(len=20) :: name @@ -74,9 +75,9 @@ function psb_s_getelem(x,index,desc_a,info) result(res) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -95,7 +96,7 @@ function psb_s_getelem(x,index,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index 85b68322..cb878c64 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -63,7 +63,8 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -79,9 +80,9 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -145,7 +146,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -190,7 +191,8 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) real(psb_spk_), allocatable :: lval(:) logical :: local_ @@ -207,9 +209,9 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -267,7 +269,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -295,7 +297,8 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -311,9 +314,9 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -381,7 +384,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -425,9 +429,9 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -491,7 +495,7 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sins_a.f90 b/base/tools/psb_sins_a.f90 index 51bd0bbd..629ad783 100644 --- a/base/tools/psb_sins_a.f90 +++ b/base/tools/psb_sins_a.f90 @@ -68,7 +68,8 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -86,9 +87,9 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -169,7 +170,7 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -248,7 +249,8 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me,dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -266,9 +268,9 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -359,7 +361,7 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sspalloc.f90 b/base/tools/psb_sspalloc.f90 index 4b092e62..15c3c538 100644 --- a/base/tools/psb_sspalloc.f90 +++ b/base/tools/psb_sspalloc.f90 @@ -52,7 +52,8 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit @@ -67,10 +68,10 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() dectype = desc_a%get_dectype() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -101,7 +102,7 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=nnz_) + call a%allocate(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='sp_all') @@ -117,7 +118,7 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 index 01187497..f4e6169d 100644 --- a/base/tools/psb_sspasb.f90 +++ b/base/tools/psb_sspasb.f90 @@ -62,7 +62,8 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_s_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -73,12 +74,12 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() ! check on BLACS grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +138,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sspfree.f90 b/base/tools/psb_sspfree.f90 index aa4cea76..968e9f9a 100644 --- a/base/tools/psb_sspfree.f90 +++ b/base/tools/psb_sspfree.f90 @@ -48,7 +48,8 @@ subroutine psb_sspfree(a, desc_a,info) type(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act character(len=20) :: name info=psb_success_ @@ -63,7 +64,7 @@ subroutine psb_sspfree(a, desc_a,info) call psb_errpush(info,name) return else - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() end if !...deallocate a.... @@ -72,7 +73,7 @@ subroutine psb_sspfree(a, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_ssphalo.F90 b/base/tools/psb_ssphalo.F90 index f8958a45..609d41b4 100644 --- a/base/tools/psb_ssphalo.F90 +++ b/base/tools/psb_ssphalo.F90 @@ -90,7 +90,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, & & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& @@ -125,10 +126,10 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -329,14 +330,14 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & acoo%val,iarcv,jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv,rvsz,brvindx,ictxt,info) + & iarcv,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv,rvsz,brvindx,ictxt,info) + & jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) @@ -425,14 +426,14 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) @@ -530,7 +531,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -557,7 +558,8 @@ Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& & data_,totxch,nxs, nxr, ncg @@ -586,10 +588,10 @@ Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -772,14 +774,14 @@ Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& @@ -874,7 +876,7 @@ Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -900,7 +902,8 @@ Subroutine psb_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,nxs, nxr, err_act, nsnds, nrcvs @@ -930,10 +933,10 @@ Subroutine psb_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1128,14 +1131,14 @@ Subroutine psb_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) @@ -1234,7 +1237,7 @@ Subroutine psb_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -1260,7 +1263,8 @@ Subroutine psb_s_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,ngtz, idx, nxs, nxr, err_act, & @@ -1292,10 +1296,10 @@ Subroutine psb_s_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1500,14 +1504,14 @@ Subroutine psb_s_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,liasnd,ljasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(liasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(ljasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) @@ -1606,7 +1610,7 @@ Subroutine psb_s_ls_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index 7a86e559..1fd6eed0 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -64,7 +64,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -75,8 +76,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_sspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -185,7 +186,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -208,7 +209,8 @@ subroutine psb_sspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -219,8 +221,8 @@ subroutine psb_sspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) name = 'psb_sspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -282,7 +284,7 @@ subroutine psb_sspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +308,8 @@ subroutine psb_sspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -317,8 +320,8 @@ subroutine psb_sspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) name = 'psb_sspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -380,7 +383,7 @@ subroutine psb_sspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -403,7 +406,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) @@ -424,8 +428,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) goto 9999 end if - ictxt = desc_ar%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_ar%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -495,7 +499,7 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -518,7 +522,8 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -530,8 +535,8 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_sspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -646,7 +651,7 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_ssprn.f90 b/base/tools/psb_ssprn.f90 index 3a750033..602867e6 100644 --- a/base/tools/psb_ssprn.f90 +++ b/base/tools/psb_ssprn.f90 @@ -53,7 +53,8 @@ Subroutine psb_ssprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name logical :: clear_ @@ -64,8 +65,8 @@ Subroutine psb_ssprn(a, desc_a,info,clear) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': start ' @@ -88,7 +89,7 @@ Subroutine psb_ssprn(a, desc_a,info,clear) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_z_glob_transpose.F90 b/base/tools/psb_z_glob_transpose.F90 index 8f7cadd5..9bc92da3 100644 --- a/base/tools/psb_z_glob_transpose.F90 +++ b/base/tools/psb_z_glob_transpose.F90 @@ -110,7 +110,8 @@ subroutine psb_lz_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) integer(psb_ipk_), intent(out) :: info ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_lpk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzt, nzd @@ -137,10 +138,10 @@ subroutine psb_lz_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -287,14 +288,14 @@ subroutine psb_lz_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),acoo%ia(nzl+1:nzl+iszr),& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ia(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%ja(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& @@ -385,7 +386,7 @@ subroutine psb_lz_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_lz_coo_glob_transpose @@ -406,7 +407,8 @@ subroutine psb_z_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) type(psb_desc_type), intent(out), optional :: desc_rx integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc, err_act, j integer(psb_ipk_) :: i, k, idx, r, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & l1, nsnds, nrcvs, nr,nc,nzl, hlstart, nzd @@ -434,10 +436,10 @@ subroutine psb_z_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_r%get_context() + ctxt = desc_r%get_context() icomm = desc_r%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -586,14 +588,14 @@ subroutine psb_z_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& & acoo%val(nzl+1:nzl+iszr),iarcv(1:iszr),& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ictxt,info) + & acoo%val(nzl+1:nzl+iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv(1:iszr),rvsz,brvindx,ictxt,info) + & iarcv(1:iszr),rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv(1:iszr),rvsz,brvindx,ictxt,info) + & jarcv(1:iszr),rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& @@ -690,7 +692,7 @@ subroutine psb_z_coo_glob_transpose(ain,desc_r,info,atrans,desc_c,desc_rx) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_z_coo_glob_transpose @@ -709,19 +711,20 @@ subroutine psb_z_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_z_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -760,19 +763,20 @@ subroutine psb_z_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_z_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -811,19 +815,20 @@ subroutine psb_lz_simple_glob_transpose_ip(ain,desc_a,info) ! type(psb_lz_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if @@ -862,19 +867,20 @@ subroutine psb_lz_simple_glob_transpose(ain,aout,desc_a,info) ! type(psb_lz_coo_sparse_mat) :: tmpc1, tmpc2 integer(psb_ipk_) :: nz1, nz2, nzh, nz - integer(psb_ipk_) :: ictxt, me, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np integer(psb_lpk_) :: i, j, k, nrow, ncol, nlz integer(psb_lpk_), allocatable :: ilv(:) character(len=80) :: aname logical, parameter :: debug=.false., dump=.false., debug_sync=.false. - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() if (debug_sync) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (me == 0) write(0,*) 'Start htranspose ' end if diff --git a/base/tools/psb_z_map.f90 b/base/tools/psb_z_map.f90 index 86858c60..eea44099 100644 --- a/base/tools/psb_z_map.f90 +++ b/base/tools/psb_z_map.f90 @@ -51,7 +51,8 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work) ! complex(psb_dpk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V' info = psb_success_ @@ -66,14 +67,14 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() + ctxt = map%p_desc_V%get_context() nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,x,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_V,info) if (info /= psb_success_) then @@ -83,7 +84,7 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() + ctxt = map%desc_V%get_context() nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -93,7 +94,7 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,xt,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_V,info) if (info /= psb_success_) then @@ -125,7 +126,8 @@ subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_z_vect_type),pointer :: ptx, pty complex(psb_dpk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_U2V_v' info = psb_success_ @@ -140,8 +142,8 @@ subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_V%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() if (present(vty)) then @@ -154,7 +156,7 @@ subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,x,zzero,pty,info) if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_V,info) @@ -167,8 +169,8 @@ subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_V%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_V%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_U%get_local_rows() nc1 = map%desc_U%get_local_cols() nr2 = map%desc_V%get_global_rows() @@ -188,7 +190,7 @@ subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,ptx,zzero,pty,info) if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_V,info) @@ -232,7 +234,8 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work) ! complex(psb_dpk_), allocatable :: xt(:), yt(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt + & map_kind, nr + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U' info = psb_success_ @@ -247,14 +250,14 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() + ctxt = map%p_desc_U%get_context() nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,x,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_U,info) if (info /= psb_success_) then @@ -264,7 +267,7 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() + ctxt = map%desc_U%get_context() nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -274,7 +277,7 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work) if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,xt,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then - call psb_sum(ictxt,yt(1:nr2)) + call psb_sum(ctxt,yt(1:nr2)) end if if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_U,info) if (info /= psb_success_) then @@ -305,7 +308,8 @@ subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) type(psb_z_vect_type),pointer :: ptx, pty complex(psb_dpk_), allocatable :: xta(:), yta(:) integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, nr, ictxt, iam, np + & map_kind, nr, iam, np + type(psb_ctxt_type) :: ctxt character(len=20), parameter :: name='psb_map_V2U_v' info = psb_success_ @@ -320,8 +324,8 @@ subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) select case(map_kind) case(psb_map_aggr_) - ictxt = map%p_desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%p_desc_U%get_context() + call psb_info(ctxt,iam,np) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() if (present(vty)) then @@ -334,7 +338,7 @@ subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,x,zzero,pty,info) if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%p_desc_U,info) @@ -347,8 +351,8 @@ subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) case(psb_map_gen_linear_) - ictxt = map%desc_U%get_context() - call psb_info(ictxt,iam,np) + ctxt = map%desc_U%get_context() + call psb_info(ctxt,iam,np) nr1 = map%desc_V%get_local_rows() nc1 = map%desc_V%get_local_cols() nr2 = map%desc_U%get_global_rows() @@ -369,7 +373,7 @@ subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty) if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,ptx,zzero,pty,info) if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then yta = pty%get_vect() - call psb_sum(ictxt,yta(1:nr2)) + call psb_sum(ctxt,yta(1:nr2)) call pty%set(yta) end if if (info == psb_success_) call psb_geaxpby(alpha,pty,beta,y,map%desc_U,info) diff --git a/base/tools/psb_z_par_csr_spspmm.f90 b/base/tools/psb_z_par_csr_spspmm.f90 index 3be9d0e8..4b88ffab 100644 --- a/base/tools/psb_z_par_csr_spspmm.f90 +++ b/base/tools/psb_z_par_csr_spspmm.f90 @@ -73,7 +73,8 @@ Subroutine psb_z_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: ncol, nnz type(psb_lz_csr_sparse_mat) :: ltcsr type(psb_z_csr_sparse_mat) :: tcsr @@ -91,9 +92,9 @@ Subroutine psb_z_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -150,7 +151,7 @@ Subroutine psb_z_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -168,7 +169,8 @@ Subroutine psb_lz_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_lpk_) :: nacol, nccol, nnz type(psb_lz_csr_sparse_mat) :: tcsr1 logical :: update_desc_c @@ -185,9 +187,9 @@ Subroutine psb_lz_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -244,7 +246,7 @@ Subroutine psb_lz_par_csr_spspmm(acsr,desc_a,bcsr,ccsr,desc_c,info,data) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_z_remap.F90 b/base/tools/psb_z_remap.F90 new file mode 100644 index 00000000..f9c5c39c --- /dev/null +++ b/base/tools/psb_z_remap.F90 @@ -0,0 +1,255 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! +! +! Subroutine: psb_z_remap +! +! Arguments: +! desc_in - type(psb_desc_type). The communication descriptor to be cloned. +! desc_out - type(psb_desc_type). The output communication descriptor. +! info - integer. Return code. +subroutine psb_z_remap(np_remap, desc_in, a_in, ipd, isrc, nrsrc, naggr, & + & desc_out, a_out, info) + + use psb_base_mod, psb_protect_name => psb_z_remap + + implicit none + !....parameters... + integer(psb_ipk_), intent(in) :: np_remap + type(psb_desc_type), intent(inout) :: desc_in + type(psb_zspmat_type), intent(inout) :: a_in + type(psb_zspmat_type), intent(out) :: a_out + type(psb_desc_type), intent(out) :: desc_out + integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) + integer(psb_ipk_), intent(out) :: info + + + ! locals + type(psb_ctxt_type) :: ctxt, newctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_) :: rnp, rme + integer(psb_ipk_) :: ipdest, id1, id2, imd, i, nsrc + integer(psb_ipk_), allocatable :: newnl(:), nzsrc(:), ids(:) + type(psb_lz_coo_sparse_mat) :: acoo_snd, acoo_rcv + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cdcpy' + + ctxt = desc_in%get_context() + + ! check on blacs grid + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Entered' + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + +!!$ write(0,*) ' Remapping from ',np,' onto ', np_remap + + if (desc_in%get_fmt() == 'BLOCK') then + ! + ! Should we spread the processes in the new context, + ! or should we keep them close? + ! + if (.true.) then + allocate(ids(0:np_remap-1)) + if (np_remap <= np/2) then + ids(0) = 0 + do ipdest=1,np_remap -1 + ids(ipdest) = ids(ipdest-1) + np/np_remap + end do +!!$ write(0,*) ' IDS ',ids(:) + else + do ipdest = 0, np_remap-1 + ids(ipdest) = ipdest + end do + end if + call psb_init(newctxt,np=np_remap,basectxt=ctxt,ids=ids) + else + call psb_init(newctxt,np=np_remap,basectxt=ctxt) + end if + + call psb_info(newctxt,rme,rnp) +!!$ write(0,*) 'Old context: ',me,np,' New context: ',rme,rnp + call psb_bcast(ctxt,rnp) + allocate(newnl(rnp),naggr(np),stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (rnp >= np) then + write(0,*) ' No remapping on larger proc count now' + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + naggr = 0 + + ! + ! Compute destination for my data. + ! Simplistic reallocation: divide the NP processes + ! across the new ones (as balanced as possible), + ! then send all data from old to new process + ! + id2 = np/rnp + id1 = id2+1 + imd = mod(np,rnp) + if (me < (imd*id1)) then + ipdest = (me/id1) + else + ipdest = ( ((me-imd*id1)/id2) + imd) + end if + if (allocated(ids)) then + ipd = ids(ipdest) + else + ipd = ipdest + end if +!!$ write(0,*) ' Sending my data from ',me,' to ', & +!!$ & ipd, 'out of ',rnp,rnp-1 + + ! + ! Compute local rows for all new + ! processes; will have a BLOCK distribution + ! + newnl = 0 + newnl(ipdest+1) = desc_in%get_local_rows() + call psb_sum(ctxt,newnl) + + if (rme>=0) then + ! + if (rme < imd) then + isrc = [ (i, i=rme*id1,min(rme*id1+id1-1,np-1)) ] + else + isrc = [ (i, i= imd*id1+((rme-imd))*id2,& + & min(imd*id1+(rme-imd)*id2+id2-1,np-1) ) ] + end if +!!$ write(0,*) me,rme,imd,' ISRC: ',isrc(:) + nsrc = size(isrc) +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',desc_out%get_local_rows(),desc_out%get_global_rows() + else +!!$ write(0,*) me,rme,'In ',desc_in%get_local_rows(),desc_in%get_global_rows(),& +!!$ & ' out ',0,0 + end if + else + write(0,*) 'Right now only BLOCK on input ' + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Collect matrices on their destinations + ! + block + integer(psb_ipk_) :: nzsnd, nzrcv, ip + integer(psb_ipk_) :: nrl, ncl, nzl, nzp + call a_in%cp_to(acoo_snd) + nzsnd = acoo_snd%get_nzeros() + call psb_snd(ctxt,nzsnd,ipd) + call psb_snd(ctxt,desc_in%get_local_rows(),ipd) + ! Convert to global numbering + call psb_loc_to_glob(acoo_snd%ia(1:nzsnd),desc_in,info) + call psb_loc_to_glob(acoo_snd%ja(1:nzsnd),desc_in,info) + + call psb_snd(ctxt,acoo_snd%ia(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%ja(1:nzsnd),ipd) + call psb_snd(ctxt,acoo_snd%val(1:nzsnd),ipd) + + if (rme>=0) then + ! prepare to receive + nzsrc = isrc + nrsrc = isrc + nzl = 0 + do ip=1, nsrc + call psb_rcv(ctxt,nzsrc(ip),isrc(ip)) + call psb_rcv(ctxt,nrsrc(ip),isrc(ip)) + nzl = nzl + nzsrc(ip) + end do +!!$ write(0,*) rme,' Check on NR:',newnl(rme+1),sum(nrsrc) + call acoo_rcv%allocate(newnl(rme+1),newnl(rme+1),nzl) + nrl = acoo_rcv%get_nrows() + ncl = acoo_rcv%get_ncols() + nzp = 0 + do ip=1, nsrc + call psb_rcv(ctxt,acoo_rcv%ia(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%ja(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + call psb_rcv(ctxt,acoo_rcv%val(nzp+1:nzp+nzsrc(ip)),isrc(ip)) + nzp = nzp + nzsrc(ip) + end do + call acoo_rcv%set_nzeros(nzp) +!!$ write(0,*) rme,' Collected: ',& +!!$ & acoo_rcv%get_nrows(),acoo_rcv%get_ncols(),acoo_rcv%get_nzeros() + + ! + ! New descriptor + ! + call psb_cdall(newctxt,desc_out,info,nl=newnl(rme+1)) + ! Insert + call psb_spall(a_out,desc_out,info) + call psb_spins(nzp,acoo_rcv%ia(1:nzp),acoo_rcv%ja(1:nzp),& + & acoo_rcv%val(1:nzp),a_out,desc_out,info) + ! Assemble + call psb_cdasb(desc_out,info) + call psb_spasb(a_out,desc_out,info) + +!!$ write(0,*) rme,' Regenerated: ',& +!!$ & desc_out%get_local_rows(), desc_out%get_local_cols(),& +!!$ & a_out%get_nrows(),a_out%get_ncols(),a_out%get_nzeros() + naggr(me+1) = desc_out%get_local_rows() + else + naggr(me+1) = 0 + end if + call psb_sum(ctxt,naggr) + + end block + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_z_remap diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index 1bf67e74..fa84827e 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -52,7 +52,7 @@ subroutine psb_zalloc_vect(x, desc_a,info) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -63,9 +63,9 @@ subroutine psb_zalloc_vect(x, desc_a,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -105,7 +105,7 @@ subroutine psb_zalloc_vect(x, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -133,8 +133,9 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) integer(psb_ipk_), optional, intent(in) :: n,lb !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -145,9 +146,9 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -176,9 +177,9 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -216,7 +217,7 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -235,8 +236,9 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) integer(psb_ipk_), optional, intent(in) :: n !locals + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -247,9 +249,9 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -273,9 +275,9 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -308,7 +310,7 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zallc_a.f90 b/base/tools/psb_zallc_a.f90 index 9fa7993c..1af815e4 100644 --- a/base/tools/psb_zallc_a.f90 +++ b/base/tools/psb_zallc_a.f90 @@ -55,7 +55,8 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) !locals integer(psb_ipk_) :: err,nr,i,j,n_,err_act - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: exch(3) character(len=20) :: name @@ -67,9 +68,9 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -91,9 +92,9 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) !global check on n parameters if (me == psb_root_) then exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) else - call psb_bcast(ictxt,exch(1),root=psb_root_) + call psb_bcast(ctxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ call psb_errpush(info,name,i_err=(/ione/)) @@ -124,7 +125,7 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -183,7 +184,8 @@ subroutine psb_zallocv(x, desc_a,info,n) !locals integer(psb_ipk_) :: nr,i,err_act - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -196,9 +198,9 @@ subroutine psb_zallocv(x, desc_a,info,n) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -238,7 +240,7 @@ subroutine psb_zallocv(x, desc_a,info,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 6ebf4281..e3d3a555 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -62,7 +62,8 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -73,13 +74,13 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) name = 'psb_zgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -117,7 +118,7 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -135,7 +136,8 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me, i, n + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, i, n integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -146,13 +148,13 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) name = 'psb_zgeasb_v' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -198,7 +200,7 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -217,7 +219,8 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ @@ -229,7 +232,7 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) name = 'psb_zgeasb' - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -246,7 +249,7 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) end if endif - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -286,7 +289,7 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zasb_a.f90 b/base/tools/psb_zasb_a.f90 index 0492475a..e8c9db99 100644 --- a/base/tools/psb_zasb_a.f90 +++ b/base/tools/psb_zasb_a.f90 @@ -52,7 +52,8 @@ subroutine psb_zasb(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,nrow,ncol, err_act integer(psb_ipk_) :: i1sz, i2sz integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -74,9 +75,9 @@ subroutine psb_zasb(x, desc_a, info, scratch) call psb_errpush(info,name) goto 9999 endif - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_) & @@ -96,7 +97,7 @@ subroutine psb_zasb(x, desc_a, info, scratch) endif ! check size - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() i1sz = size(x,dim=1) @@ -129,7 +130,7 @@ subroutine psb_zasb(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -188,7 +189,8 @@ subroutine psb_zasbv(x, desc_a, info, scratch) logical, intent(in), optional :: scratch ! local variables - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: i1sz,nrow,ncol, err_act integer(psb_ipk_) :: debug_level, debug_unit logical :: scratch_ @@ -201,13 +203,13 @@ subroutine psb_zasbv(x, desc_a, info, scratch) info = psb_err_internal_error_ ; goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() scratch_ = .false. if (present(scratch)) scratch_ = scratch - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then @@ -252,7 +254,7 @@ subroutine psb_zasbv(x, desc_a, info, scratch) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zcdbldext.F90 b/base/tools/psb_zcdbldext.F90 index 528e78f5..32d0b51a 100644 --- a/base/tools/psb_zcdbldext.F90 +++ b/base/tools/psb_zcdbldext.F90 @@ -90,7 +90,9 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ integer(psb_lpk_) :: gidx, lnz - integer(psb_mpk_) :: icomm, ictxt, me, np, minfo + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np + integer(psb_mpk_) :: icomm, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) @@ -114,9 +116,9 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) If (debug_level >= psb_debug_outer_) & & Write(debug_unit,*) me,' ',trim(name),& @@ -187,7 +189,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_)then Write(debug_unit,*) me,' ',trim(name),& & ': BEGIN ',nhalo, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif ! ! Ok, since we are only estimating, do it as follows: @@ -215,7 +217,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) If (debug_level >= psb_debug_outer_) then Write(debug_unit,*) me,' ',trim(name),':Start',& & lworks,lworkr, desc_ov%indxmap%get_state() - call psb_barrier(ictxt) + call psb_barrier(ctxt) endif @@ -593,7 +595,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),':Done Crea_Index' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_move_alloc(t_halo_out,halo,info) ! @@ -672,7 +674,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),': converting indexes' - call psb_barrier(ictxt) + call psb_barrier(ctxt) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) @@ -701,7 +703,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ione*ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index cdb9d047..6f7f057b 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -46,7 +46,8 @@ subroutine psb_zfree_vect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -60,9 +61,9 @@ subroutine psb_zfree_vect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -86,7 +87,7 @@ subroutine psb_zfree_vect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -100,7 +101,8 @@ subroutine psb_zfree_vect_r2(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act, i + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act, i character(len=20) :: name @@ -114,9 +116,9 @@ subroutine psb_zfree_vect_r2(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +139,7 @@ subroutine psb_zfree_vect_r2(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -152,7 +154,8 @@ subroutine psb_zfree_multivect(x, desc_a, info) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act character(len=20) :: name @@ -166,9 +169,9 @@ subroutine psb_zfree_multivect(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -192,7 +195,7 @@ subroutine psb_zfree_multivect(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zfree_a.f90 b/base/tools/psb_zfree_a.f90 index 7dc6498e..95fa38d1 100644 --- a/base/tools/psb_zfree_a.f90 +++ b/base/tools/psb_zfree_a.f90 @@ -48,7 +48,8 @@ subroutine psb_zfree(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_zfree' @@ -64,9 +65,9 @@ subroutine psb_zfree(x, desc_a, info) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -92,7 +93,7 @@ subroutine psb_zfree(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -116,7 +117,8 @@ subroutine psb_zfreev(x, desc_a, info) integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act character(len=20) :: name name='psb_zfreev' @@ -131,9 +133,9 @@ subroutine psb_zfreev(x, desc_a, info) call psb_errpush(info,name) goto 9999 end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -157,7 +159,7 @@ subroutine psb_zfreev(x, desc_a, info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zgetelem.f90 b/base/tools/psb_zgetelem.f90 index 5e7e975f..2024f094 100644 --- a/base/tools/psb_zgetelem.f90 +++ b/base/tools/psb_zgetelem.f90 @@ -55,7 +55,8 @@ function psb_z_getelem(x,index,desc_a,info) result(res) !locals integer(psb_ipk_) :: localindex(1) - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_lpk_) :: gindex(1) integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) character(len=20) :: name @@ -74,9 +75,9 @@ function psb_z_getelem(x,index,desc_a,info) result(res) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -95,7 +96,7 @@ function psb_z_getelem(x,index,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index 8307434b..19020379 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -63,7 +63,8 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -79,9 +80,9 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -145,7 +146,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -190,7 +191,8 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) complex(psb_dpk_), allocatable :: lval(:) logical :: local_ @@ -207,9 +209,9 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -267,7 +269,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -295,7 +297,8 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -311,9 +314,9 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -381,7 +384,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -409,7 +412,8 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -425,9 +429,9 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) goto 9999 end if - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -491,7 +495,7 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zins_a.f90 b/base/tools/psb_zins_a.f90 index 7db797f8..4b068117 100644 --- a/base/tools/psb_zins_a.f90 +++ b/base/tools/psb_zins_a.f90 @@ -68,7 +68,8 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np, me, dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -86,9 +87,9 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -169,7 +170,7 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -248,7 +249,8 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) !locals..... integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: ictxt,np,me,dupl_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,dupl_ integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -266,9 +268,9 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) return end if - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -359,7 +361,7 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zspalloc.f90 b/base/tools/psb_zspalloc.f90 index 81099dcb..16d48734 100644 --- a/base/tools/psb_zspalloc.f90 +++ b/base/tools/psb_zspalloc.f90 @@ -52,7 +52,8 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, np, me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit @@ -67,10 +68,10 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() dectype = desc_a%get_dectype() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then info = psb_err_context_error_ @@ -101,7 +102,7 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=nnz_) + call a%allocate(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='sp_all') @@ -117,7 +118,7 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index 6cdfc61f..b5966110 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -62,7 +62,8 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_z_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me, err_act integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -73,12 +74,12 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() ! check on BLACS grid - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) @@ -137,7 +138,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zspfree.f90 b/base/tools/psb_zspfree.f90 index b002999d..73f0bb27 100644 --- a/base/tools/psb_zspfree.f90 +++ b/base/tools/psb_zspfree.f90 @@ -48,7 +48,8 @@ subroutine psb_zspfree(a, desc_a,info) type(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info !...locals.... - integer(psb_ipk_) :: ictxt, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: err_act character(len=20) :: name info=psb_success_ @@ -63,7 +64,7 @@ subroutine psb_zspfree(a, desc_a,info) call psb_errpush(info,name) return else - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() end if !...deallocate a.... @@ -72,7 +73,7 @@ subroutine psb_zspfree(a, desc_a,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zsphalo.F90 b/base/tools/psb_zsphalo.F90 index a862ce99..6aece956 100644 --- a/base/tools/psb_zsphalo.F90 +++ b/base/tools/psb_zsphalo.F90 @@ -90,7 +90,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, & & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& @@ -125,10 +126,10 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -329,14 +330,14 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,iarcv,jarcv,rvsz,brvindx,ictxt,info) + & acoo%val,iarcv,jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & iarcv,rvsz,brvindx,ictxt,info) + & iarcv,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & jarcv,rvsz,brvindx,ictxt,info) + & jarcv,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) @@ -425,14 +426,14 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) @@ -530,7 +531,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -557,7 +558,8 @@ Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& & data_,totxch,nxs, nxr, ncg @@ -586,10 +588,10 @@ Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -772,14 +774,14 @@ Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& @@ -874,7 +876,7 @@ Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -900,7 +902,8 @@ Subroutine psb_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,nxs, nxr, err_act, nsnds, nrcvs @@ -930,10 +933,10 @@ Subroutine psb_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1128,14 +1131,14 @@ Subroutine psb_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) @@ -1234,7 +1237,7 @@ Subroutine psb_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -1260,7 +1263,8 @@ Subroutine psb_z_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_), intent(in), optional :: data type(psb_desc_type),Intent(in), optional, target :: col_desc ! ...local scalars.... - integer(psb_ipk_) :: ictxt, np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter,proc,i, n_el_send,n_el_recv,& & n_elem, j,ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & data_,totxch,ngtz, idx, nxs, nxr, err_act, & @@ -1292,10 +1296,10 @@ Subroutine psb_z_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() icomm = desc_a%get_mpic() - Call psb_info(ictxt, me, np) + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' @@ -1500,14 +1504,14 @@ Subroutine psb_z_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& select case(psb_get_sp_a2av_alg()) case(psb_sp_a2av_smpl_triad_) call psb_simple_triad_a2av(valsnd,liasnd,ljasnd,sdsz,bsdindx,& - & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_smpl_v_) call psb_simple_a2av(valsnd,sdsz,bsdindx,& - & acoo%val,rvsz,brvindx,ictxt,info) + & acoo%val,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(liasnd,sdsz,bsdindx,& - & acoo%ia,rvsz,brvindx,ictxt,info) + & acoo%ia,rvsz,brvindx,ctxt,info) if (info == psb_success_) call psb_simple_a2av(ljasnd,sdsz,bsdindx,& - & acoo%ja,rvsz,brvindx,ictxt,info) + & acoo%ja,rvsz,brvindx,ctxt,info) case(psb_sp_a2av_mpi_) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) @@ -1606,7 +1610,7 @@ Subroutine psb_z_lz_csr_halo(a,desc_a,blk,info,rowcnv,colcnv,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index 6926bdc0..525ed415 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -64,7 +64,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -75,8 +76,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_zspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -185,7 +186,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -208,7 +209,8 @@ subroutine psb_zspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -219,8 +221,8 @@ subroutine psb_zspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) name = 'psb_zspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -282,7 +284,7 @@ subroutine psb_zspins_csr_lirp(nr,irp,ja,val,irw,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -306,7 +308,8 @@ subroutine psb_zspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_) :: nrow, err_act, ncol, spstate, nz, i, j integer(psb_lpk_) :: ir - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -317,8 +320,8 @@ subroutine psb_zspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) name = 'psb_zspins_csr' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nr < 0) then info = 1111 @@ -380,7 +383,7 @@ subroutine psb_zspins_csr_iirp(nr,irw,irp,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -403,7 +406,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) @@ -424,8 +428,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) goto 9999 end if - ictxt = desc_ar%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_ar%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -495,7 +499,7 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -518,7 +522,8 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ @@ -530,8 +535,8 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) name = 'psb_zspins' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (nz < 0) then info = 1111 @@ -646,7 +651,7 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/base/tools/psb_zsprn.f90 b/base/tools/psb_zsprn.f90 index aa87a8f0..c1676bed 100644 --- a/base/tools/psb_zsprn.f90 +++ b/base/tools/psb_zsprn.f90 @@ -53,7 +53,8 @@ Subroutine psb_zsprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name logical :: clear_ @@ -64,8 +65,8 @@ Subroutine psb_zsprn(a, desc_a,info,clear) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': start ' @@ -88,7 +89,7 @@ Subroutine psb_zsprn(a, desc_a,info,clear) call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/cbind/base/psb_base_tools_cbind_mod.F90 b/cbind/base/psb_base_tools_cbind_mod.F90 index 6d31778a..f47627d9 100644 --- a/cbind/base/psb_base_tools_cbind_mod.F90 +++ b/cbind/base/psb_base_tools_cbind_mod.F90 @@ -23,16 +23,18 @@ contains call psb_clean_errstack() end function psb_c_clean_errstack - function psb_c_cdall_vg(ng,vg,ictxt,cdh) bind(c,name='psb_c_cdall_vg') result(res) + function psb_c_cdall_vg(ng,vg,cctxt,cdh) bind(c,name='psb_c_cdall_vg') result(res) implicit none integer(psb_c_ipk_) :: res integer(psb_c_lpk_), value :: ng - integer(psb_c_ipk_), value :: ictxt + type(psb_c_object_type), value :: cctxt integer(psb_c_ipk_) :: vg(*) type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info + type(psb_ctxt_type) :: ctxt + ctxt = psb_c2f_ctxt(cctxt) res = -1 if (ng <=0) then @@ -50,22 +52,25 @@ contains allocate(descp,stat=info) if (info < 0) return - call psb_cdall(ictxt,descp,info,vg=vg(1:ng)) + call psb_cdall(ctxt,descp,info,vg=vg(1:ng)) cdh%item = c_loc(descp) res = info end function psb_c_cdall_vg - function psb_c_cdall_vl(nl,vl,ictxt,cdh) bind(c,name='psb_c_cdall_vl') result(res) + function psb_c_cdall_vl(nl,vl,cctxt,cdh) bind(c,name='psb_c_cdall_vl') result(res) implicit none integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nl, ictxt + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: nl integer(psb_c_lpk_) :: vl(*) type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info, ixb + type(psb_ctxt_type) :: ctxt + ctxt = psb_c2f_ctxt(cctxt) res = -1 if (nl <=0) then @@ -86,23 +91,26 @@ contains ixb = psb_c_get_index_base() if (ixb == 1) then - call psb_cdall(ictxt,descp,info,vl=vl(1:nl)) + call psb_cdall(ctxt,descp,info,vl=vl(1:nl)) else - call psb_cdall(ictxt,descp,info,vl=(vl(1:nl)+(1-ixb))) + call psb_cdall(ctxt,descp,info,vl=(vl(1:nl)+(1-ixb))) end if cdh%item = c_loc(descp) res = info end function psb_c_cdall_vl - function psb_c_cdall_nl(nl,ictxt,cdh) bind(c,name='psb_c_cdall_nl') result(res) + function psb_c_cdall_nl(nl,cctxt,cdh) bind(c,name='psb_c_cdall_nl') result(res) implicit none integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nl, ictxt + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: nl type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info + type(psb_ctxt_type) :: ctxt + ctxt = psb_c2f_ctxt(cctxt) res = -1 if (nl <=0) then @@ -120,21 +128,24 @@ contains allocate(descp,stat=info) if (info < 0) return - call psb_cdall(ictxt,descp,info,nl=nl) + call psb_cdall(ctxt,descp,info,nl=nl) cdh%item = c_loc(descp) res = info end function psb_c_cdall_nl - function psb_c_cdall_repl(n,ictxt,cdh) bind(c,name='psb_c_cdall_repl') result(res) + function psb_c_cdall_repl(n,cctxt,cdh) bind(c,name='psb_c_cdall_repl') result(res) implicit none integer(psb_c_ipk_) :: res integer(psb_c_lpk_), value :: n - integer(psb_c_ipk_), value :: ictxt + type(psb_c_object_type), value :: cctxt type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info + type(psb_ctxt_type) :: ctxt + ctxt = psb_c2f_ctxt(cctxt) + res = -1 if (n <=0) then @@ -152,7 +163,7 @@ contains allocate(descp,stat=info) if (info < 0) return - call psb_cdall(ictxt,descp,info,mg=n,repl=.true.) + call psb_cdall(ctxt,descp,info,mg=n,repl=.true.) cdh%item = c_loc(descp) res = info @@ -301,7 +312,8 @@ contains end function psb_c_cd_get_global_cols - function psb_c_cd_get_global_indices(idx,nidx,owned,cdh) bind(c,name='psb_c_cd_get_global_indices') result(res) + function psb_c_cd_get_global_indices(idx,nidx,owned,cdh) & + & bind(c,name='psb_c_cd_get_global_indices') result(res) implicit none integer(psb_c_ipk_) :: res diff --git a/cbind/base/psb_c_base.c b/cbind/base/psb_c_base.c index 4683e49c..045a1a7c 100644 --- a/cbind/base/psb_c_base.c +++ b/cbind/base/psb_c_base.c @@ -11,6 +11,27 @@ psb_c_descriptor* psb_c_new_descriptor() return(temp); } +void psb_c_delete_descriptor(psb_c_descriptor* cdh) +{ + if (cdh != NULL) free(cdh); + return; +} + +psb_c_ctxt* psb_c_new_ctxt() +{ + psb_c_ctxt* temp; + + temp=(psb_c_ctxt *) malloc(sizeof(psb_c_ctxt)); + temp->ctxt=NULL; + return(temp); +} + +void psb_c_delete_ctxt(psb_c_ctxt* cctxt) +{ + if (cctxt != NULL) free(cctxt); + return; +} + void psb_c_print_errmsg() { diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index 0b7d09e2..bc4eb021 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -43,6 +43,11 @@ extern "C" { } psb_c_descriptor; + typedef struct PSB_C_CTXT { + psb_i_t *ctxt; + } psb_c_ctxt; + + psb_i_t psb_c_error(); psb_i_t psb_c_clean_errstack(); @@ -54,34 +59,37 @@ extern "C" { void psb_c_seterraction_abort(); /* Environment routines */ - psb_i_t psb_c_init(); - void psb_c_exit_ctxt(psb_i_t ictxt); - void psb_c_exit(psb_i_t ictxt); - void psb_c_abort(psb_i_t ictxt); - void psb_c_barrier(psb_i_t ictxt); - void psb_c_info(psb_i_t ictxt, psb_i_t *iam, psb_i_t *np); + void psb_c_init(psb_c_ctxt *cctxt); + void psb_c_exit(psb_c_ctxt cctxt); + void psb_c_exit_ctxt(psb_c_ctxt cctxt); + void psb_c_abort(psb_c_ctxt cctxt); + void psb_c_barrier(psb_c_ctxt cctxt); + void psb_c_info(psb_c_ctxt cctxt, psb_i_t *iam, psb_i_t *np); psb_d_t psb_c_wtime(); psb_i_t psb_c_get_errstatus(); psb_i_t psb_c_get_index_base(); void psb_c_set_index_base(psb_i_t base); - void psb_c_mbcast(psb_i_t ictxt, psb_i_t n, psb_m_t *v, psb_i_t root); - void psb_c_ibcast(psb_i_t ictxt, psb_i_t n, psb_i_t *v, psb_i_t root); - void psb_c_lbcast(psb_i_t ictxt, psb_i_t n, psb_l_t *v, psb_i_t root); - void psb_c_ebcast(psb_i_t ictxt, psb_i_t n, psb_e_t *v, psb_i_t root); - void psb_c_sbcast(psb_i_t ictxt, psb_i_t n, psb_s_t *v, psb_i_t root); - void psb_c_dbcast(psb_i_t ictxt, psb_i_t n, psb_d_t *v, psb_i_t root); - void psb_c_cbcast(psb_i_t ictxt, psb_i_t n, psb_c_t *v, psb_i_t root); - void psb_c_zbcast(psb_i_t ictxt, psb_i_t n, psb_z_t *v, psb_i_t root); - void psb_c_hbcast(psb_i_t ictxt, const char *v, psb_i_t root); + void psb_c_mbcast(psb_c_ctxt cctxt, psb_i_t n, psb_m_t *v, psb_i_t root); + void psb_c_ibcast(psb_c_ctxt cctxt, psb_i_t n, psb_i_t *v, psb_i_t root); + void psb_c_lbcast(psb_c_ctxt cctxt, psb_i_t n, psb_l_t *v, psb_i_t root); + void psb_c_ebcast(psb_c_ctxt cctxt, psb_i_t n, psb_e_t *v, psb_i_t root); + void psb_c_sbcast(psb_c_ctxt cctxt, psb_i_t n, psb_s_t *v, psb_i_t root); + void psb_c_dbcast(psb_c_ctxt cctxt, psb_i_t n, psb_d_t *v, psb_i_t root); + void psb_c_cbcast(psb_c_ctxt cctxt, psb_i_t n, psb_c_t *v, psb_i_t root); + void psb_c_zbcast(psb_c_ctxt cctxt, psb_i_t n, psb_z_t *v, psb_i_t root); + void psb_c_hbcast(psb_c_ctxt cctxt, const char *v, psb_i_t root); /* Descriptor/integer routines */ psb_c_descriptor* psb_c_new_descriptor(); - psb_i_t psb_c_cdall_vg(psb_l_t ng, psb_i_t *vg, psb_i_t ictxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_vl(psb_i_t nl, psb_l_t *vl, psb_i_t ictxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_nl(psb_i_t nl, psb_i_t ictxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_repl(psb_l_t n, psb_i_t ictxt, psb_c_descriptor *cd); + void psb_c_delete_descriptor(psb_c_descriptor *); + psb_c_ctxt* psb_c_new_ctxt(); + void psb_c_delete_ctxt(psb_c_ctxt *); + psb_i_t psb_c_cdall_vg(psb_l_t ng, psb_i_t *vg, psb_c_ctxt cctxt, psb_c_descriptor *cd); + psb_i_t psb_c_cdall_vl(psb_i_t nl, psb_l_t *vl, psb_c_ctxt cctxt, psb_c_descriptor *cd); + psb_i_t psb_c_cdall_nl(psb_i_t nl, psb_c_ctxt cctxt, psb_c_descriptor *cd); + psb_i_t psb_c_cdall_repl(psb_l_t n, psb_c_ctxt cctxt, psb_c_descriptor *cd); psb_i_t psb_c_cdasb(psb_c_descriptor *cd); psb_i_t psb_c_cdfree(psb_c_descriptor *cd); psb_i_t psb_c_cdins(psb_i_t nz, const psb_l_t *ia, const psb_l_t *ja, psb_c_descriptor *cd); diff --git a/cbind/base/psb_cpenv_mod.f90 b/cbind/base/psb_cpenv_mod.f90 index ac311fa2..a4d588c2 100644 --- a/cbind/base/psb_cpenv_mod.f90 +++ b/cbind/base/psb_cpenv_mod.f90 @@ -22,7 +22,7 @@ contains end subroutine psb_c_set_index_base function psb_c_get_errstatus() bind(c) result(res) - use psb_base_mod, only : psb_get_errstatus + use psb_base_mod, only : psb_get_errstatus, psb_ctxt_type implicit none integer(psb_c_ipk_) :: res @@ -30,85 +30,125 @@ contains res = psb_get_errstatus() end function psb_c_get_errstatus - function psb_c_init() bind(c) - use psb_base_mod, only : psb_init + subroutine psb_c_init(cctxt) bind(c) + use psb_base_mod, only : psb_init, psb_ctxt_type implicit none - integer(psb_c_ipk_) :: psb_c_init - - integer :: ictxt + type(psb_c_object_type) :: cctxt + type(psb_ctxt_type), pointer :: ctxt + integer :: info - call psb_init(ictxt) - psb_c_init = ictxt - end function psb_c_init + if (c_associated(cctxt%item)) then + call c_f_pointer(cctxt%item,ctxt) + deallocate(ctxt,stat=info) + if (info /= 0) return + end if + allocate(ctxt,stat=info) + if (info /= 0) return + call psb_init(ctxt) + cctxt%item = c_loc(ctxt) + + end subroutine psb_c_init - subroutine psb_c_exit_ctxt(ictxt) bind(c) - use psb_base_mod, only : psb_exit - integer(psb_c_ipk_), value :: ictxt + function psb_c2f_ctxt(cctxt) result(res) + implicit none + type(psb_c_object_type), value :: cctxt + type(psb_ctxt_type), pointer :: res + + !res%ctxt = cctxt%ctxt + if (.not.c_associated(cctxt%item)) then + write(0,*) 'Null item in c2f_ctxt? ' + flush(0) + end if + if (c_associated(cctxt%item)) call c_f_pointer(cctxt%item,res) + end function psb_c2f_ctxt + + subroutine psb_c_exit_ctxt(cctxt) bind(c) + use psb_base_mod, only : psb_exit, psb_ctxt_type + type(psb_c_object_type), value :: cctxt - call psb_exit(ictxt,close=.false.) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) + call psb_exit(ctxt,close=.false.) return end subroutine psb_c_exit_ctxt - subroutine psb_c_exit(ictxt) bind(c) - use psb_base_mod, only : psb_exit - integer(psb_c_ipk_), value :: ictxt + subroutine psb_c_exit(cctxt) bind(c) + use psb_base_mod, only : psb_exit, psb_ctxt_type + type(psb_c_object_type), value :: cctxt + + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) - call psb_exit(ictxt) + call psb_exit(ctxt) return end subroutine psb_c_exit - subroutine psb_c_abort(ictxt) bind(c) - use psb_base_mod, only : psb_abort - integer(psb_c_ipk_), value :: ictxt + subroutine psb_c_abort(cctxt) bind(c) + use psb_base_mod, only : psb_abort, psb_ctxt_type + type(psb_c_object_type), value :: cctxt - call psb_abort(ictxt) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) + call psb_abort(ctxt) return end subroutine psb_c_abort - subroutine psb_c_info(ictxt,iam,np) bind(c) - use psb_base_mod, only : psb_info - integer(psb_c_ipk_), value :: ictxt + subroutine psb_c_info(cctxt,iam,np) bind(c) + use psb_base_mod, only : psb_info, psb_ctxt_type + type(psb_c_object_type), value :: cctxt integer(psb_c_ipk_) :: iam,np - call psb_info(ictxt,iam,np) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) + call psb_info(ctxt,iam,np) return end subroutine psb_c_info - subroutine psb_c_barrier(ictxt) bind(c) - use psb_base_mod, only : psb_barrier - integer(psb_c_ipk_), value :: ictxt + subroutine psb_c_barrier(cctxt) bind(c) + use psb_base_mod, only : psb_barrier, psb_ctxt_type + type(psb_c_object_type), value :: cctxt - call psb_barrier(ictxt) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) + call psb_barrier(ctxt) end subroutine psb_c_barrier real(c_double) function psb_c_wtime() bind(c) - use psb_base_mod, only : psb_wtime + use psb_base_mod, only : psb_wtime, psb_ctxt_type psb_c_wtime = psb_wtime() end function psb_c_wtime - subroutine psb_c_mbcast(ictxt,n,v,root) bind(c) - use psb_base_mod, only : psb_bcast + subroutine psb_c_mbcast(cctxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast, psb_ctxt_type implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root integer(psb_c_mpk_) :: v(*) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) + if (n < 0) then write(0,*) 'Wrong size in BCAST' return end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_mbcast - subroutine psb_c_ibcast(ictxt,n,v,root) bind(c) - use psb_base_mod, only : psb_bcast + subroutine psb_c_ibcast(cctxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast, psb_ctxt_type implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root integer(psb_c_ipk_) :: v(*) + type(psb_ctxt_type), pointer :: ctxt + + ctxt => psb_c2f_ctxt(cctxt) if (n < 0) then write(0,*) 'Wrong size in BCAST' @@ -116,44 +156,53 @@ contains end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_ibcast - subroutine psb_c_lbcast(ictxt,n,v,root) bind(c) - use psb_base_mod, only : psb_bcast + subroutine psb_c_lbcast(cctxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast, psb_ctxt_type implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root integer(psb_c_lpk_) :: v(*) - + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) + if (n < 0) then write(0,*) 'Wrong size in BCAST' return end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_lbcast - subroutine psb_c_ebcast(ictxt,n,v,root) bind(c) - use psb_base_mod, only : psb_bcast + subroutine psb_c_ebcast(cctxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast, psb_ctxt_type implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root integer(psb_c_epk_) :: v(*) - + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) + if (n < 0) then write(0,*) 'Wrong size in BCAST' return end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_ebcast - subroutine psb_c_sbcast(ictxt,n,v,root) bind(c) + subroutine psb_c_sbcast(cctxt,n,v,root) bind(c) use psb_base_mod implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root real(c_float) :: v(*) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) if (n < 0) then write(0,*) 'Wrong size in BCAST' @@ -161,14 +210,17 @@ contains end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_sbcast - subroutine psb_c_dbcast(ictxt,n,v,root) bind(c) - use psb_base_mod, only : psb_bcast + subroutine psb_c_dbcast(cctxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast, psb_ctxt_type implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root real(c_double) :: v(*) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) if (n < 0) then write(0,*) 'Wrong size in BCAST' @@ -176,15 +228,18 @@ contains end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_dbcast - subroutine psb_c_cbcast(ictxt,n,v,root) bind(c) - use psb_base_mod, only : psb_bcast + subroutine psb_c_cbcast(cctxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast, psb_ctxt_type implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root complex(c_float_complex) :: v(*) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) if (n < 0) then write(0,*) 'Wrong size in BCAST' @@ -192,14 +247,17 @@ contains end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_cbcast - subroutine psb_c_zbcast(ictxt,n,v,root) bind(c) + subroutine psb_c_zbcast(cctxt,n,v,root) bind(c) use psb_base_mod implicit none - integer(psb_c_ipk_), value :: ictxt,n, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: n, root complex(c_double_complex) :: v(*) + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) if (n < 0) then write(0,*) 'Wrong size in BCAST' @@ -207,17 +265,20 @@ contains end if if (n==0) return - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_zbcast - subroutine psb_c_hbcast(ictxt,v,root) bind(c) - use psb_base_mod, only : psb_bcast, psb_info, psb_ipk_ + subroutine psb_c_hbcast(cctxt,v,root) bind(c) + use psb_base_mod, only : psb_bcast, psb_info, psb_ipk_, psb_ctxt_type implicit none - integer(psb_c_ipk_), value :: ictxt, root + type(psb_c_object_type), value :: cctxt + integer(psb_c_ipk_), value :: root character(c_char) :: v(*) integer(psb_ipk_) :: iam, np, n + type(psb_ctxt_type), pointer :: ctxt + ctxt => psb_c2f_ctxt(cctxt) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (iam==root) then n = 1 @@ -226,12 +287,12 @@ contains n = n + 1 end do end if - call psb_bcast(ictxt,n,root=root) - call psb_bcast(ictxt,v(1:n),root=root) + call psb_bcast(ctxt,n,root=root) + call psb_bcast(ctxt,v(1:n),root=root) end subroutine psb_c_hbcast function psb_c_f2c_errmsg(cmesg,len) bind(c) result(res) - use psb_base_mod, only : psb_errpop,psb_max_errmsg_len_ + use psb_base_mod, only : psb_errpop,psb_max_errmsg_len_, psb_ctxt_type use psb_base_string_cbind_mod implicit none character(c_char), intent(inout) :: cmesg(*) @@ -259,21 +320,20 @@ contains end if cmesg(ll) = c_null_char end function psb_c_f2c_errmsg - + subroutine psb_c_seterraction_ret() bind(c) - use psb_base_mod, only : psb_set_erraction, psb_act_ret_ + use psb_base_mod, only : psb_set_erraction, psb_act_ret_, psb_ctxt_type call psb_set_erraction(psb_act_ret_) end subroutine psb_c_seterraction_ret subroutine psb_c_seterraction_print() bind(c) - use psb_base_mod, only : psb_set_erraction, psb_act_print_ + use psb_base_mod, only : psb_set_erraction, psb_act_print_, psb_ctxt_type call psb_set_erraction(psb_act_print_) end subroutine psb_c_seterraction_print subroutine psb_c_seterraction_abort() bind(c) - use psb_base_mod, only : psb_set_erraction, psb_act_abort_ + use psb_base_mod, only : psb_set_erraction, psb_act_abort_, psb_ctxt_type call psb_set_erraction(psb_act_abort_) end subroutine psb_c_seterraction_abort - end module psb_cpenv_mod diff --git a/cbind/prec/psb_c_cprec.h b/cbind/prec/psb_c_cprec.h index 452f1c03..60c2ef87 100644 --- a/cbind/prec/psb_c_cprec.h +++ b/cbind/prec/psb_c_cprec.h @@ -14,7 +14,7 @@ extern "C" { psb_c_cprec* psb_c_new_cprec(); - psb_i_t psb_c_cprecinit(psb_i_t ictxt,psb_c_cprec *ph, const char *ptype); + psb_i_t psb_c_cprecinit(psb_c_ctxt cctxt,psb_c_cprec *ph, const char *ptype); psb_i_t psb_c_cprecbld(psb_c_cspmat *ah, psb_c_descriptor *cdh, psb_c_cprec *ph); psb_i_t psb_c_cprecfree(psb_c_cprec *ph); #ifdef __cplusplus diff --git a/cbind/prec/psb_c_dprec.h b/cbind/prec/psb_c_dprec.h index 90ab72e6..3e3c9438 100644 --- a/cbind/prec/psb_c_dprec.h +++ b/cbind/prec/psb_c_dprec.h @@ -14,7 +14,7 @@ extern "C" { psb_c_dprec* psb_c_new_dprec(); - psb_i_t psb_c_dprecinit(psb_i_t ictxt, psb_c_dprec *ph, const char *ptype); + psb_i_t psb_c_dprecinit(psb_c_ctxt cctxt, psb_c_dprec *ph, const char *ptype); psb_i_t psb_c_dprecbld(psb_c_dspmat *ah, psb_c_descriptor *cdh, psb_c_dprec *ph); psb_i_t psb_c_dprecfree(psb_c_dprec *ph); #ifdef __cplusplus diff --git a/cbind/prec/psb_c_sprec.h b/cbind/prec/psb_c_sprec.h index 57d66c01..8f6ab0c4 100644 --- a/cbind/prec/psb_c_sprec.h +++ b/cbind/prec/psb_c_sprec.h @@ -14,7 +14,7 @@ extern "C" { psb_c_sprec* psb_c_new_sprec(); - psb_i_t psb_c_sprecinit(psb_i_t ictxt, psb_c_sprec *ph, const char *ptype); + psb_i_t psb_c_sprecinit(psb_c_ctxt cctxt, psb_c_sprec *ph, const char *ptype); psb_i_t psb_c_sprecbld(psb_c_sspmat *ah, psb_c_descriptor *cdh, psb_c_sprec *ph); psb_i_t psb_c_sprecfree(psb_c_sprec *ph); #ifdef __cplusplus diff --git a/cbind/prec/psb_c_zprec.h b/cbind/prec/psb_c_zprec.h index f86e3844..40327f39 100644 --- a/cbind/prec/psb_c_zprec.h +++ b/cbind/prec/psb_c_zprec.h @@ -14,7 +14,7 @@ extern "C" { psb_c_zprec* psb_c_new_zprec(); - psb_i_t psb_c_zprecinit(psb_i_t ictxt, psb_c_zprec *ph, const char *ptype); + psb_i_t psb_c_zprecinit(psb_c_ctxt cctxt, psb_c_zprec *ph, const char *ptype); psb_i_t psb_c_zprecbld(psb_c_zspmat *ah, psb_c_descriptor *cdh, psb_c_zprec *ph); psb_i_t psb_c_zprecfree(psb_c_zprec *ph); #ifdef __cplusplus diff --git a/cbind/prec/psb_cprec_cbind_mod.f90 b/cbind/prec/psb_cprec_cbind_mod.f90 index 94c34f16..a901b830 100644 --- a/cbind/prec/psb_cprec_cbind_mod.f90 +++ b/cbind/prec/psb_cprec_cbind_mod.f90 @@ -12,20 +12,23 @@ module psb_cprec_cbind_mod contains - - function psb_c_cprecinit(ictxt,ph,ptype) bind(c) result(res) + function psb_c_cprecinit(cctxt,ph,ptype) bind(c) result(res) use psb_base_mod use psb_prec_mod + use psb_cpenv_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: ictxt + integer(psb_c_ipk_) :: res + type(psb_c_object_type), value :: cctxt type(psb_c_cprec) :: ph character(c_char) :: ptype(*) type(psb_cprec_type), pointer :: precp integer(psb_c_ipk_) :: info character(len=80) :: fptype + type(psb_ctxt_type), pointer :: ctxt + + ctxt => psb_c2f_ctxt(cctxt) res = -1 if (c_associated(ph%item)) then @@ -38,7 +41,7 @@ contains call stringc2f(ptype,fptype) - call psb_precinit(ictxt,precp,fptype,info) + call psb_precinit(ctxt,precp,fptype,info) res = min(0,info) return diff --git a/cbind/prec/psb_dprec_cbind_mod.f90 b/cbind/prec/psb_dprec_cbind_mod.f90 index d1625ad9..7f321a17 100644 --- a/cbind/prec/psb_dprec_cbind_mod.f90 +++ b/cbind/prec/psb_dprec_cbind_mod.f90 @@ -12,20 +12,23 @@ module psb_dprec_cbind_mod contains - - function psb_c_dprecinit(ictxt,ph,ptype) bind(c) result(res) + function psb_c_dprecinit(cctxt,ph,ptype) bind(c) result(res) use psb_base_mod use psb_prec_mod + use psb_cpenv_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: ictxt + integer(psb_c_ipk_) :: res + type(psb_c_object_type), value :: cctxt type(psb_c_dprec) :: ph character(c_char) :: ptype(*) type(psb_dprec_type), pointer :: precp integer(psb_c_ipk_) :: info character(len=80) :: fptype + type(psb_ctxt_type), pointer :: ctxt + + ctxt => psb_c2f_ctxt(cctxt) res = -1 if (c_associated(ph%item)) then @@ -38,7 +41,7 @@ contains call stringc2f(ptype,fptype) - call psb_precinit(ictxt,precp,fptype,info) + call psb_precinit(ctxt,precp,fptype,info) res = min(0,info) return diff --git a/cbind/prec/psb_sprec_cbind_mod.f90 b/cbind/prec/psb_sprec_cbind_mod.f90 index 5fb8a807..3ce66f52 100644 --- a/cbind/prec/psb_sprec_cbind_mod.f90 +++ b/cbind/prec/psb_sprec_cbind_mod.f90 @@ -12,20 +12,23 @@ module psb_sprec_cbind_mod contains - - function psb_c_sprecinit(ictxt,ph,ptype) bind(c) result(res) + function psb_c_sprecinit(cctxt,ph,ptype) bind(c) result(res) use psb_base_mod use psb_prec_mod + use psb_cpenv_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: ictxt + integer(psb_c_ipk_) :: res + type(psb_c_object_type), value :: cctxt type(psb_c_sprec) :: ph character(c_char) :: ptype(*) type(psb_sprec_type), pointer :: precp integer(psb_c_ipk_) :: info character(len=80) :: fptype + type(psb_ctxt_type), pointer :: ctxt + + ctxt => psb_c2f_ctxt(cctxt) res = -1 if (c_associated(ph%item)) then @@ -38,7 +41,7 @@ contains call stringc2f(ptype,fptype) - call psb_precinit(ictxt,precp,fptype,info) + call psb_precinit(ctxt,precp,fptype,info) res = min(0,info) return diff --git a/cbind/prec/psb_zprec_cbind_mod.f90 b/cbind/prec/psb_zprec_cbind_mod.f90 index 36755d23..5ca76df1 100644 --- a/cbind/prec/psb_zprec_cbind_mod.f90 +++ b/cbind/prec/psb_zprec_cbind_mod.f90 @@ -12,20 +12,23 @@ module psb_zprec_cbind_mod contains - - function psb_c_zprecinit(ictxt,ph,ptype) bind(c) result(res) + function psb_c_zprecinit(cctxt,ph,ptype) bind(c) result(res) use psb_base_mod use psb_prec_mod + use psb_cpenv_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: ictxt + integer(psb_c_ipk_) :: res + type(psb_c_object_type), value :: cctxt type(psb_c_zprec) :: ph character(c_char) :: ptype(*) type(psb_zprec_type), pointer :: precp integer(psb_c_ipk_) :: info character(len=80) :: fptype + type(psb_ctxt_type), pointer :: ctxt + + ctxt => psb_c2f_ctxt(cctxt) res = -1 if (c_associated(ph%item)) then @@ -38,7 +41,7 @@ contains call stringc2f(ptype,fptype) - call psb_precinit(ictxt,precp,fptype,info) + call psb_precinit(ctxt,precp,fptype,info) res = min(0,info) return diff --git a/cbind/test/pargen/ppdec.c b/cbind/test/pargen/ppdec.c index 986450c7..0671ec9e 100644 --- a/cbind/test/pargen/ppdec.c +++ b/cbind/test/pargen/ppdec.c @@ -120,7 +120,7 @@ double g(double x, double y, double z) } } -psb_i_t matgen(psb_i_t ictxt, psb_i_t nl, psb_i_t idim, psb_l_t vl[], +psb_i_t matgen(psb_c_ctxt cctxt, psb_i_t nl, psb_i_t idim, psb_l_t vl[], psb_c_dspmat *ah,psb_c_descriptor *cdh, psb_c_dvector *xh, psb_c_dvector *bh, psb_c_dvector *rh) { @@ -132,7 +132,7 @@ psb_i_t matgen(psb_i_t ictxt, psb_i_t nl, psb_i_t idim, psb_l_t vl[], psb_l_t irow[10*NBMAX], icol[10*NBMAX]; info = 0; - psb_c_info(ictxt,&iam,&np); + psb_c_info(cctxt,&iam,&np); deltah = (double) 1.0/(idim+1); sqdeltah = deltah*deltah; deltah2 = 2.0* deltah; @@ -223,7 +223,8 @@ psb_i_t matgen(psb_i_t ictxt, psb_i_t nl, psb_i_t idim, psb_l_t vl[], int main(int argc, char *argv[]) { - psb_i_t ictxt, iam, np; + psb_c_ctxt *cctxt; + psb_i_t iam, np; char methd[40], ptype[20], afmt[8], buffer[LINEBUFSIZE+1]; psb_i_t nparms; psb_i_t idim,info,istop,itmax,itrace,irst,iter,ret; @@ -238,13 +239,12 @@ int main(int argc, char *argv[]) psb_c_SolverOptions options; psb_c_descriptor *cdh; FILE *vectfile; - - ictxt = psb_c_init(); - psb_c_info(ictxt,&iam,&np); - fprintf(stdout,"Initialization: am %d of %d\n",iam,np); - fflush(stdout); - psb_c_barrier(ictxt); + cctxt = psb_c_new_ctxt(); + psb_c_init(cctxt); + psb_c_info(*cctxt,&iam,&np); + + psb_c_barrier(*cctxt); if (iam == 0) { fgets(buffer,LINEBUFSIZE,stdin); sscanf(buffer,"%d ",&nparms); @@ -264,22 +264,22 @@ int main(int argc, char *argv[]) sscanf(buffer,"%d",&itrace); fgets(buffer,LINEBUFSIZE,stdin); sscanf(buffer,"%d",&irst); - } + } /* Now broadcast the values, and check they're OK */ - psb_c_ibcast(ictxt,1,&nparms,0); - psb_c_hbcast(ictxt,methd,0); - psb_c_hbcast(ictxt,ptype,0); - psb_c_hbcast(ictxt,afmt,0); - psb_c_ibcast(ictxt,1,&idim,0); - psb_c_ibcast(ictxt,1,&istop,0); - psb_c_ibcast(ictxt,1,&itmax,0); - psb_c_ibcast(ictxt,1,&itrace,0); - psb_c_ibcast(ictxt,1,&irst,0); + psb_c_ibcast(*cctxt,1,&nparms,0); + psb_c_hbcast(*cctxt,methd,0); + psb_c_hbcast(*cctxt,ptype,0); + psb_c_hbcast(*cctxt,afmt,0); + psb_c_ibcast(*cctxt,1,&idim,0); + psb_c_ibcast(*cctxt,1,&istop,0); + psb_c_ibcast(*cctxt,1,&itmax,0); + psb_c_ibcast(*cctxt,1,&itrace,0); + psb_c_ibcast(*cctxt,1,&irst,0); fprintf(stderr,"%d Check on received: methd %s ptype %s afmt %s\n", iam,methd,ptype,afmt); - - psb_c_barrier(ictxt); + fflush(stderr); + psb_c_barrier(*cctxt); cdh=psb_c_new_descriptor(); psb_c_set_index_base(0); @@ -292,15 +292,15 @@ int main(int argc, char *argv[]) fprintf(stderr,"%d: Input data %d %ld %d %d\n",iam,idim,ng,nb, nl); if ((vl=malloc(nb*sizeof(psb_l_t)))==NULL) { fprintf(stderr,"On %d: malloc failure\n",iam); - psb_c_abort(ictxt); + psb_c_abort(*cctxt); } i = ((psb_l_t)iam) * nb; for (k=0; kdescriptor); @@ -412,8 +412,8 @@ int main(int argc, char *argv[]) free(cdh); - if (iam == 0) fprintf(stderr,"program completed successfully\n"); + //if (iam == 0) fprintf(stderr,"program completed successfully\n"); - psb_c_barrier(ictxt); - psb_c_exit(ictxt); + psb_c_barrier(*cctxt); + psb_c_exit(*cctxt); } diff --git a/cbind/test/pargen/runs/ppde.inp b/cbind/test/pargen/runs/ppde.inp index e0162591..d16c607f 100644 --- a/cbind/test/pargen/runs/ppde.inp +++ b/cbind/test/pargen/runs/ppde.inp @@ -2,7 +2,7 @@ BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES BJAC Preconditioner NONE DIAG BJAC CSR A Storage format CSR COO -100 Domain size (acutal system is this**3) +080 Domain size (acutal system is this**3) 1 Stopping criterion 80 MAXIT 01 ITRACE diff --git a/krylov/psb_base_krylov_conv_mod.f90 b/krylov/psb_base_krylov_conv_mod.f90 index 5139157d..be7723f5 100644 --- a/krylov/psb_base_krylov_conv_mod.f90 +++ b/krylov/psb_base_krylov_conv_mod.f90 @@ -146,15 +146,16 @@ contains real(psb_dpk_), optional, intent(out) :: err integer(psb_ipk_), optional, intent(out) :: iter - integer(psb_ipk_) :: ictxt, me, np, err_act, itrace + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act, itrace real(psb_dpk_) :: errnum, errden, eps character(len=20) :: name info = psb_success_ name = 'psb_end_conv' - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) errnum = stopdat%values(psb_ik_errnum_) errden = stopdat%values(psb_ik_errden_) diff --git a/krylov/psb_c_krylov_conv_mod.f90 b/krylov/psb_c_krylov_conv_mod.f90 index 0eb44aab..85a2bca7 100644 --- a/krylov/psb_c_krylov_conv_mod.f90 +++ b/krylov/psb_c_krylov_conv_mod.f90 @@ -61,7 +61,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name complex(psb_spk_), allocatable :: r(:) @@ -70,9 +71,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = 0.0d0 @@ -116,7 +117,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -134,15 +135,16 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) res = .false. @@ -193,7 +195,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -212,7 +214,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name type(psb_c_vect_type) :: r @@ -221,9 +224,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = dzero @@ -267,7 +270,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -284,7 +287,8 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ @@ -293,8 +297,8 @@ contains name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) @@ -345,7 +349,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_cbicg.f90 b/krylov/psb_cbicg.f90 index fbcc2d03..c3b4f472 100644 --- a/krylov/psb_cbicg.f90 +++ b/krylov/psb_cbicg.f90 @@ -123,7 +123,8 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,& logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 integer(psb_ipk_) :: itx - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat @@ -136,8 +137,8 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np diff --git a/krylov/psb_ccg.F90 b/krylov/psb_ccg.F90 index 41f64c77..fbc550e7 100644 --- a/krylov/psb_ccg.F90 +++ b/krylov/psb_ccg.F90 @@ -122,7 +122,8 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,& & n_col, n_row,err_act, ieg,nspl, istebz integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat logical :: do_cond @@ -135,9 +136,9 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) diff --git a/krylov/psb_ccgs.f90 b/krylov/psb_ccgs.f90 index 240f98e6..c25a449a 100644 --- a/krylov/psb_ccgs.f90 +++ b/krylov/psb_ccgs.f90 @@ -117,7 +117,8 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: debug_level, debug_unit complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr @@ -131,8 +132,8 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/krylov/psb_ccgstab.f90 b/krylov/psb_ccgstab.f90 index c8c1709c..22d73b85 100644 --- a/krylov/psb_ccgstab.f90 +++ b/krylov/psb_ccgstab.f90 @@ -121,7 +121,8 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, err_act, i integer(psb_ipk_) :: istop_ - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma, omega, tau type(psb_itconv_type) :: stopdat @@ -134,8 +135,8 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_ccgstabl.f90 b/krylov/psb_ccgstabl.f90 index 4c6dc896..86ca5d93 100644 --- a/krylov/psb_ccgstabl.f90 +++ b/krylov/psb_ccgstabl.f90 @@ -134,7 +134,8 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me complex(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& & omega real(psb_dpk_) :: derr @@ -148,8 +149,8 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_cfcg.F90 b/krylov/psb_cfcg.F90 index 73b221d3..00f55206 100644 --- a/krylov/psb_cfcg.F90 +++ b/krylov/psb_cfcg.F90 @@ -128,7 +128,8 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me complex(psb_spk_), allocatable, target :: aux(:) complex(psb_spk_) :: vres(3) character(len=20) :: name @@ -142,9 +143,9 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) @@ -239,7 +240,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:2)) + call psb_sum(ctxt, vres(1:2)) alpha = vres(1) beta = vres(2) @@ -278,7 +279,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) vres(3) = psb_gedot(q, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:3)) + call psb_sum(ctxt, vres(1:3)) alpha = vres(1) beta = vres(2) diff --git a/krylov/psb_cgcr.f90 b/krylov/psb_cgcr.f90 index a59b15a1..91c848a2 100644 --- a/krylov/psb_cgcr.f90 +++ b/krylov/psb_cgcr.f90 @@ -133,7 +133,8 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst complex(psb_spk_) :: hjj complex(psb_spk_), allocatable, target :: aux(:) @@ -146,9 +147,9 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) diff --git a/krylov/psb_ckrylov.f90 b/krylov/psb_ckrylov.f90 index e9f12ea1..01228234 100644 --- a/krylov/psb_ckrylov.f90 +++ b/krylov/psb_ckrylov.f90 @@ -152,16 +152,17 @@ Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,& procedure(psb_ckryl_cond_vect) :: psb_ccg_vect, psb_cfcg_vect logical :: do_alloc_wrk - integer(psb_ipk_) :: ictxt,me,np,err_act, itrace_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np,err_act, itrace_ character(len=20) :: name info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! Default return for COND if (present(cond)) cond = szero @@ -219,7 +220,7 @@ Subroutine psb_ckrylov_vect(method,a,prec,b,x,eps,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_crgmres.f90 b/krylov/psb_crgmres.f90 index 9e20350f..80aa34c3 100644 --- a/krylov/psb_crgmres.f90 +++ b/krylov/psb_crgmres.f90 @@ -137,7 +137,8 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me Real(psb_spk_) :: rni, xni, bni, ani,bn2, dt, r0n2 real(psb_dpk_) :: errnum, errden, deps, derr character(len=20) :: name @@ -149,8 +150,8 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/krylov/psb_d_krylov_conv_mod.f90 b/krylov/psb_d_krylov_conv_mod.f90 index d275bdbc..4f9b9f2e 100644 --- a/krylov/psb_d_krylov_conv_mod.f90 +++ b/krylov/psb_d_krylov_conv_mod.f90 @@ -61,7 +61,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name real(psb_dpk_), allocatable :: r(:) @@ -70,9 +71,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = 0.0d0 @@ -116,7 +117,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -134,15 +135,16 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) res = .false. @@ -193,7 +195,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -212,7 +214,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name type(psb_d_vect_type) :: r @@ -221,9 +224,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = dzero @@ -267,7 +270,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -284,7 +287,8 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ @@ -293,8 +297,8 @@ contains name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) @@ -345,7 +349,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_dbicg.f90 b/krylov/psb_dbicg.f90 index abea8b86..5ac94d3c 100644 --- a/krylov/psb_dbicg.f90 +++ b/krylov/psb_dbicg.f90 @@ -123,7 +123,8 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,& logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 integer(psb_ipk_) :: itx - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat @@ -136,8 +137,8 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np diff --git a/krylov/psb_dcg.F90 b/krylov/psb_dcg.F90 index 2166ff39..669573be 100644 --- a/krylov/psb_dcg.F90 +++ b/krylov/psb_dcg.F90 @@ -122,7 +122,8 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,& & n_col, n_row,err_act, ieg,nspl, istebz integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat logical :: do_cond @@ -135,9 +136,9 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) @@ -309,7 +310,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,& #endif info=psb_success_ end if - call psb_bcast(ictxt,cond) + call psb_bcast(ctxt,cond) end if diff --git a/krylov/psb_dcgs.f90 b/krylov/psb_dcgs.f90 index 0545483d..78a3905c 100644 --- a/krylov/psb_dcgs.f90 +++ b/krylov/psb_dcgs.f90 @@ -117,7 +117,8 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: debug_level, debug_unit real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr @@ -131,8 +132,8 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/krylov/psb_dcgstab.f90 b/krylov/psb_dcgstab.f90 index 449e5511..bec3329a 100644 --- a/krylov/psb_dcgstab.f90 +++ b/krylov/psb_dcgstab.f90 @@ -121,7 +121,8 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, err_act, i integer(psb_ipk_) :: istop_ - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma, omega, tau type(psb_itconv_type) :: stopdat @@ -134,8 +135,8 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_dcgstabl.f90 b/krylov/psb_dcgstabl.f90 index ca8a6fe0..01641226 100644 --- a/krylov/psb_dcgstabl.f90 +++ b/krylov/psb_dcgstabl.f90 @@ -134,7 +134,8 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& & omega real(psb_dpk_) :: derr @@ -148,8 +149,8 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_dfcg.F90 b/krylov/psb_dfcg.F90 index 990d70ec..12c3b3dc 100644 --- a/krylov/psb_dfcg.F90 +++ b/krylov/psb_dfcg.F90 @@ -128,7 +128,8 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_), allocatable, target :: aux(:) real(psb_dpk_) :: vres(3) character(len=20) :: name @@ -142,9 +143,9 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) @@ -239,7 +240,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:2)) + call psb_sum(ctxt, vres(1:2)) alpha = vres(1) beta = vres(2) @@ -278,7 +279,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) vres(3) = psb_gedot(q, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:3)) + call psb_sum(ctxt, vres(1:3)) alpha = vres(1) beta = vres(2) diff --git a/krylov/psb_dgcr.f90 b/krylov/psb_dgcr.f90 index 59c5e243..b7480f84 100644 --- a/krylov/psb_dgcr.f90 +++ b/krylov/psb_dgcr.f90 @@ -133,7 +133,8 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst real(psb_dpk_) :: hjj real(psb_dpk_), allocatable, target :: aux(:) @@ -146,9 +147,9 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) diff --git a/krylov/psb_dkrylov.f90 b/krylov/psb_dkrylov.f90 index a1fe405a..d5d40eaf 100644 --- a/krylov/psb_dkrylov.f90 +++ b/krylov/psb_dkrylov.f90 @@ -152,16 +152,17 @@ Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,& procedure(psb_dkryl_cond_vect) :: psb_dcg_vect, psb_dfcg_vect logical :: do_alloc_wrk - integer(psb_ipk_) :: ictxt,me,np,err_act, itrace_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np,err_act, itrace_ character(len=20) :: name info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! Default return for COND if (present(cond)) cond = dzero @@ -219,7 +220,7 @@ Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_drgmres.f90 b/krylov/psb_drgmres.f90 index f30b3391..1503748a 100644 --- a/krylov/psb_drgmres.f90 +++ b/krylov/psb_drgmres.f90 @@ -137,7 +137,8 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me Real(psb_dpk_) :: rni, xni, bni, ani,bn2, dt, r0n2 real(psb_dpk_) :: errnum, errden, deps, derr character(len=20) :: name @@ -149,8 +150,8 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/krylov/psb_s_krylov_conv_mod.f90 b/krylov/psb_s_krylov_conv_mod.f90 index ede2eb75..29713c37 100644 --- a/krylov/psb_s_krylov_conv_mod.f90 +++ b/krylov/psb_s_krylov_conv_mod.f90 @@ -61,7 +61,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name real(psb_spk_), allocatable :: r(:) @@ -70,9 +71,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = 0.0d0 @@ -116,7 +117,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -134,15 +135,16 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) res = .false. @@ -193,7 +195,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -212,7 +214,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name type(psb_s_vect_type) :: r @@ -221,9 +224,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = dzero @@ -267,7 +270,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -284,7 +287,8 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ @@ -293,8 +297,8 @@ contains name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) @@ -345,7 +349,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_sbicg.f90 b/krylov/psb_sbicg.f90 index f5f54387..609d3a5f 100644 --- a/krylov/psb_sbicg.f90 +++ b/krylov/psb_sbicg.f90 @@ -123,7 +123,8 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,& logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 integer(psb_ipk_) :: itx - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_spk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat @@ -136,8 +137,8 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np diff --git a/krylov/psb_scg.F90 b/krylov/psb_scg.F90 index cbb41e3b..c16dbf6a 100644 --- a/krylov/psb_scg.F90 +++ b/krylov/psb_scg.F90 @@ -122,7 +122,8 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,& & n_col, n_row,err_act, ieg,nspl, istebz integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat logical :: do_cond @@ -135,9 +136,9 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) @@ -309,7 +310,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,& #endif info=psb_success_ end if - call psb_bcast(ictxt,cond) + call psb_bcast(ctxt,cond) end if diff --git a/krylov/psb_scgs.f90 b/krylov/psb_scgs.f90 index b45d6b9d..48fe5372 100644 --- a/krylov/psb_scgs.f90 +++ b/krylov/psb_scgs.f90 @@ -117,7 +117,8 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: debug_level, debug_unit real(psb_spk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr @@ -131,8 +132,8 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/krylov/psb_scgstab.f90 b/krylov/psb_scgstab.f90 index 62eb965a..2a811b8d 100644 --- a/krylov/psb_scgstab.f90 +++ b/krylov/psb_scgstab.f90 @@ -121,7 +121,8 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, err_act, i integer(psb_ipk_) :: istop_ - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr real(psb_spk_) :: alpha, beta, rho, rho_old, sigma, omega, tau type(psb_itconv_type) :: stopdat @@ -134,8 +135,8 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_scgstabl.f90 b/krylov/psb_scgstabl.f90 index 5c53781d..c2fc9833 100644 --- a/krylov/psb_scgstabl.f90 +++ b/krylov/psb_scgstabl.f90 @@ -134,7 +134,8 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& & omega real(psb_dpk_) :: derr @@ -148,8 +149,8 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_sfcg.F90 b/krylov/psb_sfcg.F90 index 6c233f0e..dc770ce6 100644 --- a/krylov/psb_sfcg.F90 +++ b/krylov/psb_sfcg.F90 @@ -128,7 +128,8 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_spk_), allocatable, target :: aux(:) real(psb_spk_) :: vres(3) character(len=20) :: name @@ -142,9 +143,9 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) @@ -239,7 +240,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:2)) + call psb_sum(ctxt, vres(1:2)) alpha = vres(1) beta = vres(2) @@ -278,7 +279,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) vres(3) = psb_gedot(q, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:3)) + call psb_sum(ctxt, vres(1:3)) alpha = vres(1) beta = vres(2) diff --git a/krylov/psb_sgcr.f90 b/krylov/psb_sgcr.f90 index ce11c389..dd0aca16 100644 --- a/krylov/psb_sgcr.f90 +++ b/krylov/psb_sgcr.f90 @@ -133,7 +133,8 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst real(psb_spk_) :: hjj real(psb_spk_), allocatable, target :: aux(:) @@ -146,9 +147,9 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) diff --git a/krylov/psb_skrylov.f90 b/krylov/psb_skrylov.f90 index e2c02732..39aecc36 100644 --- a/krylov/psb_skrylov.f90 +++ b/krylov/psb_skrylov.f90 @@ -152,16 +152,17 @@ Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,& procedure(psb_skryl_cond_vect) :: psb_scg_vect, psb_sfcg_vect logical :: do_alloc_wrk - integer(psb_ipk_) :: ictxt,me,np,err_act, itrace_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np,err_act, itrace_ character(len=20) :: name info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! Default return for COND if (present(cond)) cond = szero @@ -219,7 +220,7 @@ Subroutine psb_skrylov_vect(method,a,prec,b,x,eps,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_srgmres.f90 b/krylov/psb_srgmres.f90 index f6443c30..02836dd7 100644 --- a/krylov/psb_srgmres.f90 +++ b/krylov/psb_srgmres.f90 @@ -137,7 +137,8 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me Real(psb_spk_) :: rni, xni, bni, ani,bn2, dt, r0n2 real(psb_dpk_) :: errnum, errden, deps, derr character(len=20) :: name @@ -149,8 +150,8 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/krylov/psb_z_krylov_conv_mod.f90 b/krylov/psb_z_krylov_conv_mod.f90 index 333dd031..fc88ccf6 100644 --- a/krylov/psb_z_krylov_conv_mod.f90 +++ b/krylov/psb_z_krylov_conv_mod.f90 @@ -61,7 +61,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name complex(psb_dpk_), allocatable :: r(:) @@ -70,9 +71,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = 0.0d0 @@ -116,7 +117,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -134,15 +135,16 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) res = .false. @@ -193,7 +195,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -212,7 +214,8 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name type(psb_z_vect_type) :: r @@ -221,9 +224,9 @@ contains call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) stopdat%controls(:) = 0 stopdat%values(:) = dzero @@ -267,7 +270,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -284,7 +287,8 @@ contains logical :: res integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me, np, err_act character(len=20) :: name info = psb_success_ @@ -293,8 +297,8 @@ contains name = 'psb_check_conv' call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt,me,np) + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) @@ -345,7 +349,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_zbicg.f90 b/krylov/psb_zbicg.f90 index d216c93c..c22e499a 100644 --- a/krylov/psb_zbicg.f90 +++ b/krylov/psb_zbicg.f90 @@ -123,7 +123,8 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,& logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 integer(psb_ipk_) :: itx - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat @@ -136,8 +137,8 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np diff --git a/krylov/psb_zcg.F90 b/krylov/psb_zcg.F90 index f89764ce..a4a521d8 100644 --- a/krylov/psb_zcg.F90 +++ b/krylov/psb_zcg.F90 @@ -122,7 +122,8 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,& & n_col, n_row,err_act, ieg,nspl, istebz integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr type(psb_itconv_type) :: stopdat logical :: do_cond @@ -135,9 +136,9 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) diff --git a/krylov/psb_zcgs.f90 b/krylov/psb_zcgs.f90 index c4091428..3ccce860 100644 --- a/krylov/psb_zcgs.f90 +++ b/krylov/psb_zcgs.f90 @@ -117,7 +117,8 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: debug_level, debug_unit complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma real(psb_dpk_) :: derr @@ -131,8 +132,8 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/krylov/psb_zcgstab.f90 b/krylov/psb_zcgstab.f90 index 4fca5c03..95ff129a 100644 --- a/krylov/psb_zcgstab.f90 +++ b/krylov/psb_zcgstab.f90 @@ -121,7 +121,8 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, err_act, i integer(psb_ipk_) :: istop_ - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me real(psb_dpk_) :: derr complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma, omega, tau type(psb_itconv_type) :: stopdat @@ -134,8 +135,8 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_zcgstabl.f90 b/krylov/psb_zcgstabl.f90 index bcb4b652..2cf3a0e5 100644 --- a/krylov/psb_zcgstabl.f90 +++ b/krylov/psb_zcgstabl.f90 @@ -134,7 +134,8 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me complex(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& & omega real(psb_dpk_) :: derr @@ -148,8 +149,8 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(x%v)) then diff --git a/krylov/psb_zfcg.F90 b/krylov/psb_zfcg.F90 index 14ecc985..a9eb24b7 100644 --- a/krylov/psb_zfcg.F90 +++ b/krylov/psb_zfcg.F90 @@ -128,7 +128,8 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me complex(psb_dpk_), allocatable, target :: aux(:) complex(psb_dpk_) :: vres(3) character(len=20) :: name @@ -142,9 +143,9 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) @@ -239,7 +240,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:2)) + call psb_sum(ctxt, vres(1:2)) alpha = vres(1) beta = vres(2) @@ -278,7 +279,7 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,& vres(2) = psb_gedot(w, v, desc_a, info, global = .false.) vres(3) = psb_gedot(q, v, desc_a, info, global = .false.) - call psb_sum(ictxt, vres(1:3)) + call psb_sum(ctxt, vres(1:3)) alpha = vres(1) beta = vres(2) diff --git a/krylov/psb_zgcr.f90 b/krylov/psb_zgcr.f90 index c40f2166..2399160c 100644 --- a/krylov/psb_zgcr.f90 +++ b/krylov/psb_zgcr.f90 @@ -133,7 +133,8 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_) :: n_col, naux, err_act integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: np, me, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst complex(psb_dpk_) :: hjj complex(psb_dpk_), allocatable, target :: aux(:) @@ -146,9 +147,9 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) if (.not.allocated(b%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) diff --git a/krylov/psb_zkrylov.f90 b/krylov/psb_zkrylov.f90 index 48371920..a70cc98a 100644 --- a/krylov/psb_zkrylov.f90 +++ b/krylov/psb_zkrylov.f90 @@ -152,16 +152,17 @@ Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,& procedure(psb_zkryl_cond_vect) :: psb_zcg_vect, psb_zfcg_vect logical :: do_alloc_wrk - integer(psb_ipk_) :: ictxt,me,np,err_act, itrace_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np,err_act, itrace_ character(len=20) :: name info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) - ictxt=desc_a%get_context() + ctxt=desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) ! Default return for COND if (present(cond)) cond = dzero @@ -219,7 +220,7 @@ Subroutine psb_zkrylov_vect(method,a,prec,b,x,eps,desc_a,info,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/krylov/psb_zrgmres.f90 b/krylov/psb_zrgmres.f90 index 73d7f08b..3aaf0032 100644 --- a/krylov/psb_zrgmres.f90 +++ b/krylov/psb_zrgmres.f90 @@ -137,7 +137,8 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ictxt, np, me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me Real(psb_dpk_) :: rni, xni, bni, ani,bn2, dt, r0n2 real(psb_dpk_) :: errnum, errden, deps, derr character(len=20) :: name @@ -149,8 +150,8 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - Call psb_info(ictxt, me, np) + ctxt = desc_a%get_context() + Call psb_info(ctxt, me, np) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),': from psb_info',np if (.not.allocated(b%v)) then diff --git a/prec/Makefile b/prec/Makefile index e3b727b7..ec5892fe 100644 --- a/prec/Makefile +++ b/prec/Makefile @@ -12,12 +12,20 @@ MODOBJS=psb_prec_const_mod.o\ psb_d_diagprec.o psb_d_nullprec.o psb_d_bjacprec.o psb_s_ilu_fact_mod.o \ psb_s_diagprec.o psb_s_nullprec.o psb_s_bjacprec.o psb_d_ilu_fact_mod.o \ psb_c_diagprec.o psb_c_nullprec.o psb_c_bjacprec.o psb_c_ilu_fact_mod.o \ - psb_z_diagprec.o psb_z_nullprec.o psb_z_bjacprec.o psb_z_ilu_fact_mod.o - + psb_z_diagprec.o psb_z_nullprec.o psb_z_bjacprec.o psb_z_ilu_fact_mod.o \ + psb_c_ainv_fact_mod.o psb_d_ainv_fact_mod.o psb_s_ainv_fact_mod.o psb_z_ainv_fact_mod.o \ + psb_c_ainv_tools_mod.o psb_d_ainv_tools_mod.o psb_s_ainv_tools_mod.o psb_z_ainv_tools_mod.o \ + psb_ainv_tools_mod.o \ + psb_biconjg_mod.o psb_c_biconjg_mod.o psb_d_biconjg_mod.o psb_s_biconjg_mod.o \ + psb_z_biconjg_mod.o \ + psb_c_invt_fact_mod.o psb_d_invt_fact_mod.o psb_s_invt_fact_mod.o \ + psb_z_invt_fact_mod.o\ + psb_c_invk_fact_mod.o psb_d_invk_fact_mod.o psb_s_invk_fact_mod.o \ + psb_z_invk_fact_mod.o LIBNAME=$(PRECLIBNAME) COBJS= -FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) +FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) OBJS=$(F90OBJS) $(COBJS) $(MPFOBJS) $(MODOBJS) lib: $(OBJS) impld @@ -43,15 +51,30 @@ psb_d_prec_mod.o: psb_prec_type.o psb_c_prec_mod.o: psb_prec_type.o psb_z_prec_mod.o: psb_prec_type.o psb_prec_type.o: psb_s_prec_type.o psb_d_prec_type.o psb_c_prec_type.o psb_z_prec_type.o -psb_prec_mod.o: psb_s_prec_mod.o psb_d_prec_mod.o psb_c_prec_mod.o psb_z_prec_mod.o -psb_s_bjacprec.o psb_s_diagprec.o psb_s_nullprec.o: psb_prec_mod.o psb_s_base_prec_mod.o -psb_d_bjacprec.o psb_d_diagprec.o psb_d_nullprec.o: psb_prec_mod.o psb_d_base_prec_mod.o -psb_c_bjacprec.o psb_c_diagprec.o psb_c_nullprec.o: psb_prec_mod.o psb_c_base_prec_mod.o +psb_prec_mod.o: psb_s_prec_mod.o psb_d_prec_mod.o psb_c_prec_mod.o psb_z_prec_mod.o +psb_s_bjacprec.o psb_s_diagprec.o psb_s_nullprec.o: psb_prec_mod.o psb_s_base_prec_mod.o +psb_d_bjacprec.o psb_d_diagprec.o psb_d_nullprec.o: psb_prec_mod.o psb_d_base_prec_mod.o +psb_c_bjacprec.o psb_c_diagprec.o psb_c_nullprec.o: psb_prec_mod.o psb_c_base_prec_mod.o psb_z_bjacprec.o psb_z_diagprec.o psb_z_nullprec.o: psb_prec_mod.o psb_z_base_prec_mod.o -psb_s_bjacprec.o: psb_s_ilu_fact_mod.o -psb_d_bjacprec.o: psb_d_ilu_fact_mod.o -psb_c_bjacprec.o: psb_c_ilu_fact_mod.o -psb_z_bjacprec.o: psb_z_ilu_fact_mod.o +psb_s_bjacprec.o: psb_s_ilu_fact_mod.o psb_s_ainv_fact_mod.o psb_s_invk_fact_mod.o psb_s_invt_fact_mod.o +psb_d_bjacprec.o: psb_d_ilu_fact_mod.o psb_d_ainv_fact_mod.o psb_d_invk_fact_mod.o psb_d_invt_fact_mod.o +psb_c_bjacprec.o: psb_c_ilu_fact_mod.o psb_c_ainv_fact_mod.o psb_c_invk_fact_mod.o psb_c_invt_fact_mod.o +psb_z_bjacprec.o: psb_z_ilu_fact_mod.o psb_z_ainv_fact_mod.o psb_z_invk_fact_mod.o psb_z_invt_fact_mod.o +psb_d_ainv_fact_mod.o: psb_prec_const_mod.o psb_ainv_tools_mod.o +psb_s_ainv_fact_mod.o: psb_prec_const_mod.o psb_ainv_tools_mod.o +psb_c_ainv_fact_mod.o: psb_prec_const_mod.o psb_ainv_tools_mod.o +psb_z_ainv_fact_mod.o: psb_prec_const_mod.o psb_ainv_tools_mod.o +psb_ainv_tools_mod.o: psb_c_ainv_tools_mod.o psb_d_ainv_tools_mod.o psb_s_ainv_tools_mod.o psb_z_ainv_tools_mod.o +psb_biconjg_mod.o: psb_prec_const_mod.o psb_c_biconjg_mod.o \ + psb_d_biconjg_mod.o psb_s_biconjg_mod.o psb_z_biconjg_mod.o +psb_c_invt_fact_mod.o: psb_prec_const_mod.o psb_c_ilu_fact_mod.o +psb_d_invt_fact_mod.o: psb_prec_const_mod.o psb_d_ilu_fact_mod.o +psb_s_invt_fact_mod.o: psb_prec_const_mod.o psb_s_ilu_fact_mod.o +psb_z_invt_fact_mod.o: psb_prec_const_mod.o psb_z_ilu_fact_mod.o +psb_c_invk_fact_mod.o: psb_prec_const_mod.o psb_c_ilu_fact_mod.o +psb_d_invk_fact_mod.o: psb_prec_const_mod.o psb_d_ilu_fact_mod.o +psb_s_invk_fact_mod.o: psb_prec_const_mod.o psb_s_ilu_fact_mod.o +psb_z_invk_fact_mod.o: psb_prec_const_mod.o psb_z_ilu_fact_mod.o veryclean: clean /bin/rm -f $(LIBNAME) *$(.mod) @@ -60,4 +83,3 @@ iclean: cd impl && $(MAKE) clean clean: iclean /bin/rm -f $(OBJS) $(LOCAL_MODS) - diff --git a/prec/impl/Makefile b/prec/impl/Makefile index 80e87a54..57d7c304 100644 --- a/prec/impl/Makefile +++ b/prec/impl/Makefile @@ -17,13 +17,32 @@ OBJS=psb_s_prec_type_impl.o psb_d_prec_type_impl.o \ psb_cprecbld.o psb_cprecset.o psb_cprecinit.o \ psb_z_diagprec_impl.o psb_z_bjacprec_impl.o psb_z_nullprec_impl.o \ psb_zilu_fct.o psb_z_ilu0_fact.o psb_z_iluk_fact.o psb_z_ilut_fact.o \ - psb_zprecbld.o psb_zprecset.o psb_zprecinit.o + psb_zprecbld.o psb_zprecset.o psb_zprecinit.o \ + psb_c_sparsify.o psb_d_sparsify.o psb_s_sparsify.o psb_z_sparsify.o \ + psb_crwclip.o psb_drwclip.o psb_srwclip.o psb_zrwclip.o \ + psb_c_sp_drop.o psb_d_sp_drop.o psb_s_sp_drop.o psb_z_sp_drop.o \ + psb_dsparse_biconjg_llk_noth.o psb_dsparse_biconjg_llk.o \ + psb_dsparse_biconjg_mlk.o psb_dsparse_biconjg_s_ft_llk.o \ + psb_dsparse_biconjg_s_llk.o \ + psb_csparse_biconjg_llk_noth.o psb_csparse_biconjg_llk.o \ + psb_csparse_biconjg_mlk.o psb_csparse_biconjg_s_ft_llk.o \ + psb_csparse_biconjg_s_llk.o \ + psb_zsparse_biconjg_llk_noth.o psb_zsparse_biconjg_llk.o \ + psb_zsparse_biconjg_mlk.o psb_zsparse_biconjg_s_ft_llk.o \ + psb_zsparse_biconjg_s_llk.o \ + psb_ssparse_biconjg_llk_noth.o psb_ssparse_biconjg_llk.o \ + psb_ssparse_biconjg_mlk.o psb_ssparse_biconjg_s_ft_llk.o \ + psb_ssparse_biconjg_s_llk.o \ + psb_d_ainv_bld.o psb_c_ainv_bld.o psb_s_ainv_bld.o \ + psb_z_ainv_bld.o \ + psb_c_invt_fact.o psb_d_invt_fact.o psb_s_invt_fact.o psb_z_invt_fact.o\ + psb_c_invk_fact.o psb_d_invk_fact.o psb_s_invk_fact.o psb_z_invk_fact.o LIBNAME=$(PRECLIBNAME) COBJS= -FINCLUDES=$(FMFLAG).. $(FMFLAG)$(MODDIR) +FINCLUDES=$(FMFLAG).. $(FMFLAG)$(MODDIR) -lib: $(OBJS) +lib: $(OBJS) $(AR) $(HERE)/$(LIBNAME) $(OBJS) $(RANLIB) $(HERE)/$(LIBNAME) @@ -31,4 +50,3 @@ veryclean: clean clean: /bin/rm -f $(OBJS) $(LOCAL_MODS) - diff --git a/prec/impl/psb_c_ainv_bld.f90 b/prec/impl/psb_c_ainv_bld.f90 new file mode 100644 index 00000000..5cf2a45e --- /dev/null +++ b/prec/impl/psb_c_ainv_bld.f90 @@ -0,0 +1,225 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +subroutine psb_c_ainv_bld(a,alg,fillin,thresh,wmat,d,zmat,desc,info,blck,iscale) + + use psb_base_mod + use psb_prec_const_mod + use psb_c_biconjg_mod + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,alg + real(psb_spk_), intent(in) :: thresh + type(psb_cspmat_type), intent(inout) :: wmat, zmat + complex(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: blck + integer(psb_ipk_), intent(in), optional :: iscale + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a + type(psb_c_coo_sparse_mat) :: acoo + type(psb_c_csr_sparse_mat) :: acsr + type(psb_cspmat_type) :: atmp + real(psb_spk_), allocatable :: arws(:), acls(:) + complex(psb_spk_), allocatable :: pq(:), ad(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax, iscale_ + real(psb_spk_) :: sp_thresh + complex(psb_spk_) :: weight + character(len=20) :: name, ch_err + + + info = psb_success_ + name = 'psb_cainv_bld' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + iscale_ = psb_ilu_scale_none_ + if (present(iscale)) iscale_ = iscale + weight = cone + ! + ! Check the memory available to hold the W and Z factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = desc%get_local_rows() + allocate(pq(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + ! + ! Ok, let's start first with Z (i.e. Upper) + ! + call a%csclip(acoo,info,imax=n_row,jmax=n_row) + call acsr%mv_from_coo(acoo,info) + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + + case(psb_ilu_scale_maxval_) + weight = acsr%maxval() + weight = cone/weight + call acsr%scal(weight,info) + + case(psb_ilu_scale_arcsum_) + allocate(arws(n_row),acls(n_row),ad(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + call acsr%arwsum(arws) + call acsr%aclsum(acls) + ad(1:n_row) = sqrt(sqrt(arws(1:n_row)*acls(1:n_row))) + ad(1:n_row) = cone/ad(1:n_row) + call acsr%scal(ad,info,side='L') + call acsr%scal(ad,info,side='R') + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + ! + ! Here for the actual workhorses. + ! Only biconjg is surviving for now.... + ! + call psb_sparse_biconjg(alg,n_row,acsr,pq,& + & zmat,wmat,nzrmax,sp_thresh,info) + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparse_biconjg') + goto 9999 + end if + call atmp%mv_from(acsr) + + ! + ! Is this right??? + ! + do i=1, n_row + if (abs(pq(i)) < d_epstol) then + pq(i) = cone + else + pq(i) = cone/pq(i) + end if + end do + + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + case(psb_ilu_scale_maxval_) + pq(:) = pq(:)*weight + + case(psb_ilu_scale_arcsum_) + call zmat%scal(ad,info,side='L') + call wmat%scal(ad,info,side='R') + + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + call psb_move_alloc(pq,d,info) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_ainv_bld diff --git a/prec/impl/psb_c_bjacprec_impl.f90 b/prec/impl/psb_c_bjacprec_impl.f90 index de453684..1d11e60c 100644 --- a/prec/impl/psb_c_bjacprec_impl.f90 +++ b/prec/impl/psb_c_bjacprec_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,28 +27,29 @@ ! 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. -! -! +! +! subroutine psb_c_bjac_dump(prec,info,prefix,head) use psb_base_mod use psb_c_bjacprec, psb_protect_name => psb_c_bjac_dump - implicit none + implicit none class(psb_c_bjac_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than - ! len of prefix_ + ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) - if (present(prefix)) then + if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) else prefix_ = "dump_fact_c" @@ -73,7 +74,7 @@ end subroutine psb_c_bjac_dump subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_c_bjacprec, psb_protect_name => psb_c_bjac_apply_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_c_bjac_prec_type), intent(inout) :: prec complex(psb_spk_),intent(in) :: alpha,beta @@ -87,7 +88,8 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) integer(psb_ipk_) :: n_row,n_col complex(psb_spk_), pointer :: ww(:), aux(:) type(psb_c_vect_type) :: wv, wv1 - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit logical :: do_alloc_wrk @@ -99,8 +101,8 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -116,12 +118,12 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (x%get_nrows() < n_row) then + if (x%get_nrows() < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (y%get_nrows() < n_row) then + if (y%get_nrows() < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -138,9 +140,9 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) @@ -150,19 +152,19 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) allocate(ww(n_col),aux(4*n_col),stat=info) endif - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if do_alloc_wrk = .not.prec%is_allocated_wrk() if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate (wv => prec%wrk(1), wv1 => prec%wrk(2)) - + select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) + select case(trans_) case('N') call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,wv,desc_data,info,& @@ -170,31 +172,58 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + case('T') call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,wv,desc_data,info,& & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + case('C') - + call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,wv,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + call wv1%mlt(cone,prec%dv,wv,czero,info,conjgx=trans_) - + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv1,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + case('N') + call psb_spmm(cone,prec%av(psb_l_pr_),x,czero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + if (info == psb_success_) call wv1%mlt(cone,prec%dv,wv,czero,info) + if(info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1,& + & beta,y,desc_data,info, trans=trans_, work=aux,doswap=.false.) + + case('T','C') + call psb_spmm(cone,prec%av(psb_l_pr_),x,czero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + if (info == psb_success_) call wv1%mlt(cone,prec%dv,wv,czero,info) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1, & + & beta,y,desc_data,info,trans=trans_,work=aux,doswap=.false.) + end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if - + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') @@ -202,12 +231,12 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end select end associate - + call psb_halo(y,desc_data,info,data=psb_comm_mov_) if (do_alloc_wrk) call prec%free_wrk(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -229,7 +258,7 @@ end subroutine psb_c_bjac_apply_vect subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_c_bjacprec, psb_protect_name => psb_c_bjac_apply - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_c_bjac_prec_type), intent(inout) :: prec complex(psb_spk_),intent(in) :: alpha,beta @@ -242,7 +271,9 @@ subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) ! Local variables integer(psb_ipk_) :: n_row,n_col complex(psb_spk_), pointer :: ww(:), aux(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_d_vect_type) :: tx,ty + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit character :: trans_ @@ -253,8 +284,8 @@ subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -270,12 +301,12 @@ subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (size(x) < n_row) then + if (size(x) < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(y) < n_row) then + if (size(y) < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -292,29 +323,29 @@ subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) select case(trans_) case('N') @@ -341,11 +372,42 @@ subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) & trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + + case('N') + call psb_spmm(cone,prec%av(psb_l_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('T') + call psb_spmm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('C') + call psb_spmm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * conjg(prec%dv%v%v(1:n_row)) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + end select + case default info = psb_err_internal_error_ @@ -355,8 +417,8 @@ subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_halo(y,desc_data,info,data=psb_comm_mov_) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -394,11 +456,26 @@ subroutine psb_c_bjac_precinit(prec,info) call psb_Errpush(info,name) goto 9999 end if + call psb_realloc(psb_rfpsz,prec%rprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if prec%iprcparm(:) = 0 prec%iprcparm(psb_p_type_) = psb_bjac_ prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ prec%iprcparm(psb_ilu_fill_in_) = 0 + prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_ + prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_ + prec%iprcparm(psb_inv_fillin_) = 0 + prec%iprcparm(psb_ainv_alg_) = psb_ainv_llk_ + + + prec%rprcparm(:) = 0 + prec%rprcparm(psb_fact_eps_) = 1E-1_psb_spk_ + prec%rprcparm(psb_inv_thresh_) = 1E-1_psb_spk_ call psb_erractionrestore(err_act) @@ -413,7 +490,8 @@ end subroutine psb_c_bjac_precinit subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct + use psb_c_ilu_fact_mod + use psb_c_ainv_fact_mod use psb_c_bjacprec, psb_protect_name => psb_c_bjac_precbld Implicit None @@ -425,14 +503,16 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) class(psb_c_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold - ! .. Local Scalars .. - integer(psb_ipk_) :: i, m + ! .. Local Scalars .. + integer(psb_ipk_) :: i, m, ialg, fill_in, iscale, inv_fill, iinvalg integer(psb_ipk_) :: ierr(5) character :: trans, unitd - type(psb_c_csr_sparse_mat), allocatable :: lf, uf + type(psb_cspmat_type), allocatable :: lf, uf complex(psb_spk_), allocatable :: dd(:) + real(psb_spk_) :: fact_eps, inv_thresh integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me character(len=20) :: name='c_bjac_precbld' character(len=20) :: ch_err @@ -444,9 +524,9 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_ctxt() - call prec%set_ctxt(ictxt) - call psb_info(ictxt, me, np) + ctxt=desc_a%get_ctxt() + call prec%set_ctxt(ctxt) + call psb_info(ctxt, me, np) m = a%get_nrows() if (m < 0) then @@ -458,19 +538,100 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) trans = 'N' unitd = 'U' + ! We check if all the information contained in the preconditioner structure + ! are meaningful, otherwise we give an error and get out of the build + ! procedure + ialg = prec%iprcparm(psb_ilu_ialg_) ! Integer for ILU type algorithm + iinvalg = prec%iprcparm(psb_ainv_alg_) ! Integer for AINV type algorithm + iscale = prec%iprcparm(psb_ilu_scale_) ! Integer for scaling of matrix + fact_eps = prec%rprcparm(psb_fact_eps_) ! Drop-tolerance for factorization + inv_thresh = prec%rprcparm(psb_inv_thresh_) ! Drop-tolerance for inverse + fill_in = prec%iprcparm(psb_ilu_fill_in_) ! Fill-In for factorization + inv_fill = prec%iprcparm(psb_inv_fillin_) ! Fill-In for inverse factorization + + ! Check if the type of scaling is known, pay attention that not all the + ! scalings make sense for all the factorization, if something that does not + ! make sense is required the factorization routine will fail in an + ! unnrecoverable way. + if ((iscale == psb_ilu_scale_none_).or.& + (iscale == psb_ilu_scale_maxval_).or.& + (iscale == psb_ilu_scale_diag_).or.& + (iscale == psb_ilu_scale_arwsum_).or.& + (iscale == psb_ilu_scale_aclsum_).or.& + (iscale == psb_ilu_scale_arcsum_)) then + ! Do nothing: admissible request + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_scale_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the variant for the AINV is known to the library + if( (prec%iprcparm(psb_f_type_) == psb_f_ainv_).and.(& + & (iinvalg == psb_ainv_llk_).or.(iinvalg == psb_ainv_s_llk_).or. & + & (iinvalg == psb_ainv_s_ft_llk_).or.(iinvalg == psb_ainv_llk_noth_).or.& + & (iinvalg == psb_ainv_mlk_).or.(iinvalg == psb_ainv_lmx_ ) ) ) then + ! Do nothing, these are okay + else + info=psb_err_from_subroutine_ + ch_err='psb_ainv_alg_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the drop-tolerance make sense, if fact_eps > 1 and we are requiring + ! either ILUT, or INVT we give an error. + if( (fact_eps > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ilu_t_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_fact_eps_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! It the drop-tolerance for the inverse factors, inv_thresh > 1 and we are + ! requiring AINV or, or INVT we give an error + if( (inv_thresh > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ainv_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_inv_thresh_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Checks relative to the fill-in parameters + if (prec%iprcparm(psb_f_type_) == psb_f_ilu_n_) then + if(fill_in < 0) then + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fill_in_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + else if (fill_in == 0) then + ! If the requested level of fill is equal to zero, we default to the + ! specialized ILU(0) routine + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + end if + end if + ! If no limit on the fill_in is required we allow every fill, this is needed + ! since this quantity is used to allocate the auxiliary vectors for the + ! factorization + if (inv_fill <= 0) inv_fill = m + + ! Select on the type of factorization to be used select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_) + ! ILU(0) Factorization: the total number of nonzeros of the factorized matrix + ! is equal to the one of the input matrix - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) call prec%av(i)%free() enddo deallocate(prec%av,stat=info) endif end if - if (.not.allocated(prec%av)) then + if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -497,27 +658,27 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) end if allocate(dd(n_row),stat=info) - if (info == psb_success_) then + if (info == psb_success_) then allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) end if end if end if - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) + ! This is where we have no renumbering, thus no need + call psb_ilu0_fact(ialg,a,lf,uf,dd,info) if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) call prec%av(psb_l_pr_)%set_asb() call prec%av(psb_u_pr_)%set_asb() call prec%av(psb_l_pr_)%trim() @@ -526,12 +687,375 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) ! call move_alloc(dd,prec%d) else info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' + ch_err='psb_ilu0_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(psb_f_none_) + case(psb_f_ilu_k_) + ! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on + ! the type of the variant of the algorithm the may be forgotten or added to + ! the diagonal (MILU) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ilu_t_) + ! ILU(N,E) Incomplete LU factorization with thresholding and level of fill + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ainv_) + ! Approximate Inverse Factorizations based on variants of the incomplete + ! biconjugation algorithms + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_ainv_fact(a,iinvalg,inv_fill,inv_thresh,lf,dd,uf,desc_a,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invk_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(n) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invk_fact(a,fill_in, inv_fill,lf,dd,uf,desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invt_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(eps) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_c_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invt_fact(a,fill_in,inv_fill,fact_eps,inv_thresh,lf,dd,uf,& + & desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) @@ -544,7 +1068,7 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) goto 9999 end select - if (present(amold)) then + if (present(amold)) then call prec%av(psb_l_pr_)%cscnv(info,mold=amold) call prec%av(psb_u_pr_)%cscnv(info,mold=amold) end if @@ -563,8 +1087,8 @@ subroutine psb_c_bjac_precseti(prec,what,val,info) Implicit None class(psb_c_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='c_bjac_precset' @@ -572,34 +1096,33 @@ subroutine psb_c_bjac_precseti(prec,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(prec%iprcparm)) then + if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_f_type_) prec%iprcparm(psb_f_type_) = val - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_ilu_fill_in_) prec%iprcparm(psb_ilu_fill_in_) = val + case (psb_ilu_ialg_) + prec%iprcparm(psb_ilu_ialg_) = val + + case (psb_ilu_scale_) + prec%iprcparm(psb_ilu_scale_) = val + + case (psb_ainv_alg_) + prec%iprcparm(psb_ainv_alg_) = val + + case(psb_inv_fillin_) + prec%iprcparm(psb_inv_fillin_) = val + case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what end select @@ -609,3 +1132,45 @@ subroutine psb_c_bjac_precseti(prec,what,val,info) 9999 call psb_error_handler(err_act) return end subroutine psb_c_bjac_precseti + +subroutine psb_c_bjac_precsetr(prec,what,val,info) + + use psb_base_mod + use psb_c_bjacprec, psb_protect_name => psb_c_bjac_precsetr + Implicit None + + class(psb_c_bjac_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, nrow + character(len=20) :: name='c_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%rprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + + case (psb_fact_eps_) + prec%rprcparm(psb_fact_eps_) = val + + case (psb_inv_thresh_) + prec%rprcparm(psb_inv_thresh_) = val + + case default + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_bjac_precsetr diff --git a/prec/impl/psb_c_diagprec_impl.f90 b/prec/impl/psb_c_diagprec_impl.f90 index f31aae1e..0b20c7ef 100644 --- a/prec/impl/psb_c_diagprec_impl.f90 +++ b/prec/impl/psb_c_diagprec_impl.f90 @@ -38,15 +38,16 @@ subroutine psb_c_diag_dump(prec,info,prefix,head) integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/impl/psb_c_ilu0_fact.f90 b/prec/impl/psb_c_ilu0_fact.f90 index c4097dea..1a3e1046 100644 --- a/prec/impl/psb_c_ilu0_fact.f90 +++ b/prec/impl/psb_c_ilu0_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_cilu0_fact.f90 ! ! Subroutine: psb_cilu0_fact @@ -75,7 +75,7 @@ ! ! This routine computes either the ILU(0) or the MILU(0) factorization of ! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a given level of a ! multilevel preconditioner. ! @@ -83,10 +83,10 @@ ! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, ! SIAM, 2003, Chapter 10. ! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is CSR. +! The diagonal of the U factor is stored separately (actually, the inverse of the +! diagonal entries is stored; this is then managed in the solve stage associated ! to the ILU(0)/MILU(0) factorization). ! ! The routine copies and factors "on the fly" from a and blck into l (L factor), @@ -94,7 +94,7 @@ ! ! This implementation of ILU(0)/MILU(0) is faster than the implementation in ! psb_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! +! ! ! Arguments: ! ialg - integer, input. @@ -121,7 +121,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_cspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -129,7 +129,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. -! +! subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) use psb_base_mod @@ -157,30 +157,30 @@ subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(upd)) then - upd_ = psb_toupper(upd) + if (present(upd)) then + upd_ = psb_toupper(upd) else upd_ = 'F' end if - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -212,12 +212,12 @@ subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() if(info.ne.0) then @@ -226,7 +226,7 @@ subroutine psb_cilu0_fact(ialg,a,l,u,d,info,blck, upd) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - deallocate(blck_) + deallocate(blck_) endif call psb_erractionrestore(err_act) @@ -243,9 +243,9 @@ contains ! Version: complex ! Note: internal subroutine of psb_cilu0_fact. ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' ! (block-Jacobi preconditioner/solver, Additive Schwarz ! preconditioner) corresponding to a given level of a multilevel preconditioner. ! @@ -257,7 +257,7 @@ contains ! ! The routine copies and factors "on the fly" from the sparse matrix structures a ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! + ! ! ! Arguments: ! ialg - integer, input. @@ -296,7 +296,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - complex(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -305,18 +305,18 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output. ! The number of nonzero entries in lval. ! l2 - integer, output. ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_cilu0_factint(ialg,a,b,& & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: ialg @@ -332,7 +332,7 @@ contains complex(psb_spk_) :: dia,temp integer(psb_ipk_), parameter :: nrb=16 type(psb_c_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: int_err(5) character(len=20) :: name, ch_err name='psb_cilu0_factint' @@ -346,10 +346,10 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione,ialg,izero,izero,izero/)) goto 9999 end select @@ -363,7 +363,7 @@ contains end if m = ma+mb - if (psb_toupper(upd) == 'F' ) then + if (psb_toupper(upd) == 'F' ) then lirp(1) = 1 uirp(1) = 1 l1 = 0 @@ -379,14 +379,14 @@ contains if (i <= ma) then ! ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval + ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) else ! ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval + ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) @@ -437,7 +437,7 @@ contains ! dia = dia - temp*uval(jj) cycle updateloop - ! + ! else if (j > i) then ! ! search u(i,*) (i-th row of U) for a matching index j @@ -454,23 +454,23 @@ contains end if enddo end if - ! - ! If we get here we missed the cycle updateloop, which means + ! + ! If we get here we missed the cycle updateloop, which means ! that this entry does not match; thus we accumulate on the ! diagonal for MILU(0). ! - if (ialg == psb_milu_n_) then + if (ialg == psb_milu_n_) then dia = dia - temp*uval(jj) end if enddo updateloop enddo - ! + ! ! Check the pivot size - ! + ! if (abs(dia) < s_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') abs(dia) @@ -493,7 +493,7 @@ contains else write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 @@ -515,7 +515,7 @@ contains ! Version: complex ! Note: internal subroutine of psb_cilu0_fact ! - ! This routine copies a row of a sparse matrix A, stored in the psb_cspmat_type + ! This routine copies a row of a sparse matrix A, stored in the psb_cspmat_type ! data structure a, into the arrays lval and uval and into the scalar variable ! dia, corresponding to the lower and upper triangles of A and to the diagonal ! entry of the row, respectively. The entries in lval and uval are stored @@ -529,14 +529,14 @@ contains ! ! The routine is used by psb_cilu0_factint in the computation of the ILU(0)/MILU(0) ! factorization of a local sparse matrix. - ! + ! ! TODO: modify the routine to allow copying into output L and U that are ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! then use the ILU(0) internal for subsequent calls with the same pattern. ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -570,13 +570,13 @@ contains ! to the CSR storage format. ! uval - complex(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the - ! upper triangle are copied. + ! upper triangle are copied. ! ktrw - integer, input/output. ! The index identifying the last entry taken from the ! staging buffer trw. See below. ! trw - type(psb_cspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -608,10 +608,10 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - if (psb_toupper(upd) == 'F') then + if (psb_toupper(upd) == 'F') then - select type(aa => a%a) - type is (psb_c_csr_sparse_mat) + select type(aa => a%a) + type is (psb_c_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format @@ -633,19 +633,19 @@ contains end if enddo - class default + class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into lval, dia, uval, through ! successive calls to ilu_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) + call aa%csget(i,i+irb-1,trw,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='csget' @@ -656,7 +656,7 @@ contains end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) @@ -680,7 +680,7 @@ contains write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 diff --git a/prec/impl/psb_c_iluk_fact.f90 b/prec/impl/psb_c_iluk_fact.f90 index 8748816d..c4ebc678 100644 --- a/prec/impl/psb_c_iluk_fact.f90 +++ b/prec/impl/psb_c_iluk_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_ciluk_fact.f90 ! ! Subroutine: psb_ciluk_fact @@ -74,7 +74,7 @@ ! Contains: psb_ciluk_factint, iluk_copyin, iluk_fact, iluk_copyout. ! ! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to +! diagonal blocks of a distributed matrix. These factorizations are used to ! build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a certain level of a ! multilevel preconditioner. @@ -88,7 +88,7 @@ ! U factors is CSR. The diagonal of the U factor is stored separately (actually, ! the inverse of the diagonal entries is stored; this is then managed in the solve ! stage associated to the ILU(k)/MILU(k) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -118,7 +118,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_cspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -126,7 +126,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_base_mod @@ -143,7 +143,7 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) complex(psb_spk_), intent(inout) :: d(:) ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act - + type(psb_cspmat_type), pointer :: blck_ type(psb_c_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -152,17 +152,17 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -170,7 +170,7 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -203,15 +203,15 @@ subroutine psb_ciluk_fact(fill_in,ialg,a,l,u,d,info,blck) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -280,7 +280,7 @@ contains ! according to the CSR storage format. ! lia2 - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. + ! of the L factor in laspk, according to the CSR storage format. ! uval - complex(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -289,12 +289,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in laspk. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_ciluk_factint(fill_in,ialg,a,b,& @@ -304,7 +304,7 @@ contains implicit none - ! Arguments + ! Arguments integer(psb_ipk_), intent(in) :: fill_in, ialg type(psb_cspmat_type),intent(in) :: a,b integer(psb_ipk_),intent(inout) :: l1,l2,info @@ -330,14 +330,14 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,& & i_err=(/itwo,ialg,izero,izero,izero/)) goto 9999 end select - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) @@ -349,7 +349,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the iluk_copyin function + ! Allocate a temporary buffer for the iluk_copyin function ! call trw%allocate(izero,izero,ione) @@ -361,7 +361,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -381,34 +381,34 @@ contains uplevs(:) = m+1 row(:) = czero rowlevs(:) = -(m+1) - + ! ! Cycle over the matrix rows ! do i = 1, m - + ! ! At each iteration of the loop we keep in a heap the column indices ! affected by the factorization. The heap is initialized and filled ! in the iluk_copyin routine, and updated during the elimination, in ! the iluk_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = czero if (i<=ma) then ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) else ! ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! + ! (as (i-ma)-th row) + ! call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) endif - + ! Do an elimination step on the current row. It turns out we only ! need to keep track of fill levels for the upper triangle, hence we ! do not have a lowlevs variable. @@ -417,7 +417,7 @@ contains & d,uja,uirp,uval,uplevs,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) if (info /= psb_success_) then @@ -474,11 +474,11 @@ contains ! ! This routine is used by psb_ciluk_factint in the computation of the ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -510,7 +510,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_cspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -521,8 +521,8 @@ contains use psb_base_mod implicit none - - ! Arguments + + ! Arguments type(psb_cspmat_type), intent(in) :: a type(psb_c_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i,m,jmin,jmax @@ -542,17 +542,17 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - call heap%init(info) + call heap%init(info) - select type (aa=> a%a) - type is (psb_c_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_c_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! - + do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) rowlevs(k) = 0 call heap%insert(k,info) @@ -562,14 +562,14 @@ contains class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to iluk_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -581,11 +581,11 @@ contains ktrw=1 end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) rowlevs(k) = 0 call heap%insert(k,info) @@ -674,10 +674,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i, fill_in integer(psb_ipk_), intent(inout) :: nidx,info integer(psb_ipk_), intent(inout) :: rowlevs(:) @@ -690,7 +690,7 @@ contains complex(psb_spk_) :: rwk info = psb_success_ - if (.not.allocated(idxs)) then + if (.not.allocated(idxs)) then allocate(idxs(200),stat=info) if (info /= psb_success_) return endif @@ -702,34 +702,34 @@ contains ! do ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) return - ! + ! ! Just in case an index has been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k nidx = nidx + 1 - if (nidx>size(idxs)) then + if (nidx>size(idxs)) then call psb_realloc(nidx+psb_heap_resize,idxs,info) if (info /= psb_success_) return end if idxs(nidx) = k - - if ((row(k) /= czero).and.(rowlevs(k) <= fill_in).and.(ki) then + else if (j>i) then ! ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! ! Figure out a good reallocation size! ! isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -941,11 +941,11 @@ contains end if uja(l2) = j uval(l2) = row(j) - uplevs(l2) = rowlevs(j) + uplevs(l2) = rowlevs(j) else if (ialg == psb_milu_n_) then ! ! MILU(k): add discarded entries to the diagonal one - ! + ! d(i) = d(i) + row(j) end if ! @@ -963,13 +963,13 @@ contains lirp(i+1) = l1 + 1 uirp(i+1) = l2 + 1 - ! + ! ! Check the pivot size ! if (abs(d(i)) < s_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) diff --git a/prec/impl/psb_c_ilut_fact.f90 b/prec/impl/psb_c_ilut_fact.f90 index 06b8b477..633899de 100644 --- a/prec/impl/psb_c_ilut_fact.f90 +++ b/prec/impl/psb_c_ilut_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_cilut_fact.f90 ! ! Subroutine: psb_cilut_fact @@ -87,7 +87,7 @@ ! CSR. The diagonal of the U factor is stored separately (actually, the ! inverse of the diagonal entries is stored; this is then managed in the ! solve stage associated to the ILU(k,t) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -114,7 +114,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_cspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -122,9 +122,9 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - + use psb_base_mod use psb_c_ilu_fact_mod, psb_protect_name => psb_cilut_fact @@ -141,7 +141,7 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) integer(psb_ipk_), intent(in), optional :: iscale ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - + type(psb_cspmat_type), pointer :: blck_ type(psb_c_csr_sparse_mat) :: ll, uu real(psb_spk_) :: scale @@ -151,34 +151,34 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) info = psb_success_ call psb_erractionsave(err_act) - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) goto 9999 end if - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(iscale)) then + if (present(iscale)) then iscale_ = iscale else iscale_ = psb_ilu_scale_none_ end if - - select case(iscale_) + + select case(iscale_) case(psb_ilu_scale_none_) scale = sone case(psb_ilu_scale_maxval_) @@ -189,10 +189,10 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) goto 9999 end select - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -225,15 +225,15 @@ subroutine psb_cilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -298,7 +298,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - complex(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -307,12 +307,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in lval. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_cilut_factint(fill_in,thres,a,b,& @@ -320,7 +320,7 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: fill_in @@ -355,7 +355,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the ilut_copyin function + ! Allocate a temporary buffer for the ilut_copyin function ! call trw%allocate(izero,izero,ione) if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) @@ -366,7 +366,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -396,10 +396,10 @@ contains ! in the ilut_copyin function, and updated during the elimination, in ! the ilut_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = czero - if (i<=ma) then + if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& & row,heap,ktrw,trw,info) else @@ -414,7 +414,7 @@ contains & d,uja,uirp,uval,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) @@ -429,7 +429,7 @@ contains ! ! Adjust diagonal accounting for scale factor ! - if (weight /= sone) then + if (weight /= sone) then d(1:m) = d(1:m)*weight end if @@ -469,7 +469,7 @@ contains ! - storing into a heap the column indices of the nonzero entries of the copied ! row; ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; + ! in the part of the row belonging to the upper triangle; ! - computing the 2-norm of the row. ! The output array row is such that it contains a full row of A, i.e. it contains ! also the zero entries of the row. This is useful for the elimination step @@ -482,11 +482,11 @@ contains ! ! This routine is used by psb_cilut_factint in the computation of the ILU(k,t) ! factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -533,7 +533,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_cspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -542,7 +542,7 @@ contains subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& & nrmi,weight,row,heap,ktrw,trw,info) use psb_base_mod - implicit none + implicit none type(psb_cspmat_type), intent(in) :: a type(psb_c_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd @@ -584,29 +584,29 @@ contains dmaxup = szero nrmi = szero - select type (aa=> a%a) - type is (psb_c_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_c_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if end if end if end do - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 @@ -617,16 +617,16 @@ contains class default - + ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to ilut_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -639,18 +639,18 @@ contains kin = ktrw nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if @@ -734,10 +734,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i integer(psb_ipk_), intent(inout) :: nidx,info real(psb_spk_), intent(in) :: thres,nrmi @@ -753,23 +753,23 @@ contains call psb_ensure_size(200*ione,idxs,info) if (info /= psb_success_) return nidx = 0 - lastk = -1 + lastk = -1 ! ! Do while there are indices to be processed ! do - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) exit - ! + ! ! An index may have been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k lowert: if (k nidx) exit if (idxs(idxp) >= i) exit @@ -987,8 +987,8 @@ contains ! if (abs(witem) < thres*nrmi) cycle - nz = nz + 1 - xw(nz) = witem + nz = nz + 1 + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1000,9 +1000,9 @@ contains ! ! Now we have to take out the first nlw+fill_in entries - ! + ! if (nz <= nlw+fill_in) then - ! + ! ! Just copy everything from xw, and it is already ordered ! else @@ -1014,7 +1014,7 @@ contains call psb_errpush(info,name,a_err='psb_heap_get_first') goto 9999 end if - + xw(k) = witem xwid(k) = widx end do @@ -1029,15 +1029,15 @@ contains ! Copy out the lower part of the row ! do k=1,nz - l1 = l1 + 1 + l1 = l1 + 1 if (size(lval) < l1) then - ! + ! ! Figure out a good reallocation size! - ! + ! isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -1046,25 +1046,25 @@ contains lja(l1) = xwid(k) lval(l1) = xw(indx(k)) end do - + ! ! Make sure idxp points to the diagonal entry ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do idxp = idxp + 1 if (idxp > nidx) exit if (idxs(idxp) >= i) exit end do end if end if - if (idxp > size(idxs)) then + if (idxp > size(idxs)) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' else - if (idxs(idxp) > i) then + if (idxs(idxp) > i) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then + else if (idxs(idxp) /= i) then !!$ write(0,*) 'Warning: impossible error: diagonal has vanished' else ! @@ -1076,7 +1076,7 @@ contains if (abs(d(i)) < s_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) @@ -1092,7 +1092,7 @@ contains end if ! - ! Now the upper part + ! Now the upper part ! call heap%init(info,dir=psb_asort_down_) @@ -1104,15 +1104,15 @@ contains nz = 0 do - + idxp = idxp + 1 if (idxp > nidx) exit widx = idxs(idxp) - if (widx <= i) then + if (widx <= i) then !!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) cycle end if - if (widx > m) then + if (widx > m) then !!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) cycle end if @@ -1120,12 +1120,12 @@ contains ! ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle end if nz = nz + 1 - xw(nz) = witem + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1133,7 +1133,7 @@ contains call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 end if - + end do ! @@ -1141,7 +1141,7 @@ contains ! we include entry jmaxup. ! if (nz <= nup+fill_in) then - ! + ! ! Just copy everything from xw ! fndmaxup=.true. @@ -1155,13 +1155,13 @@ contains if (widx == jmaxup) fndmaxup=.true. end do end if - if ((i psb_c_invk_bld + use psb_c_ilu_fact_mod + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_cspmat_type), intent(inout) :: lmat, umat + complex(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_cspmat_type) :: atmp + complex(psb_spk_), allocatable :: pq(:), pd(:) + integer(psb_ipk_), allocatable :: uplevs(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + character(len=20) :: name, ch_err + + + info = psb_success_ + name='psb_cinvk_bld' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + + call psb_iluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + !,uplevs=uplevs) + !call psb_ciluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + ! + ! Compute the aprox U^-1 and L^-1 + ! + call psb_sparse_invk(n_row,umat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_sparse_invk(n_row,lmat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_invk_bld + +subroutine psb_csparse_invk(n,a,z,fill_in,info,inlevs) + + use psb_base_mod + use psb_c_invk_fact_mod, psb_protect_name => psb_csparse_invk + + integer(psb_ipk_), intent(in) :: n + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:), jz(:) + complex(psb_spk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:), idxs(:) + complex(psb_spk_), allocatable :: row(:) + type(psb_c_coo_sparse_mat) :: trw + type(psb_c_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx + type(psb_i_heap) :: heap + + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_sp_invk' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + allocate(uplevs(acsr%get_nzeros()),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + uplevs(:) = 0 + row(:) = czero + rowlevs(:) = -(n+1) + + call zcsr%allocate(n,n,n*fill_in) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + call psb_ensure_size(n+1, idxs, info) + + + ! + ! + zcsr%irp(1) = 1 + nzz = 0 + + l2 = 0 + outer: do i = 1, n-1 + ! ZW = e_i + call psb_invk_copyin(i,n,acsr,ione,n,row,rowlevs,heap,ktrw,trw,info,& + & sign=-sone,inlevs=inlevs) + row(i) = cone + rowlevs(i) = 0 + + ! Update loop + call psb_invk_inv(fill_in,i,row,rowlevs,heap,& + & acsr%ja,acsr%irp,acsr%val,uplevs,nidx,idxs,info) + + call psb_invk_copyout(fill_in,i,n,row,rowlevs,nidx,idxs,& + & l2,zcsr%ja,zcsr%irp,zcsr%val,info) + + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = cone + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + call zcsr%set_sorted() + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_csparse_invk + +subroutine psb_c_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,sign,inlevs) + + use psb_base_mod + use psb_c_invk_fact_mod, psb_protect_name => psb_c_invk_copyin + + implicit none + + ! Arguments + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + complex(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act, nz + integer(psb_ipk_), parameter :: nrb=16 + real(psb_spk_) :: sign_ + character(len=20), parameter :: name='invk_copyin' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + if (present(sign)) then + sign_ = sign + else + sign_ = sone + end if + + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + if (present(inlevs)) then + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = inlevs(j) + call heap%insert(k,info) + end if + end do + else + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_invk_copyin + + +subroutine psb_c_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + + use psb_base_mod + use psb_c_invk_fact_mod, psb_protect_name => psb_c_invk_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + complex(psb_spk_), allocatable, intent(inout) :: uaspk(:) + complex(psb_spk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: j,isz,err_act,int_err(5),idxp + character(len=20), parameter :: name='psb_ciluk_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + do idxp=1,nidx + + j = idxs(idxp) + + if (j>=i) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uaspk) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,uaspk,info) + if (info == psb_success_) call psb_realloc(isz,uia1,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uia1(l2) = j + uaspk(l2) = row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = czero + rowlevs(j) = -(m+1) + end if + end do + + uia2(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_invk_copyout + +subroutine psb_cinvk_inv(fill_in,i,row,rowlevs,heap,ja,irp,val,uplevs,& + & nidx,idxs,info) + + use psb_base_mod + use psb_c_invk_fact_mod, psb_protect_name => psb_cinvk_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:),uplevs(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + real(psb_dpk_) :: rwk + + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) then +!!$ write(psb_err_unit,*) 'IINVK: ',i,' returning at ',lastk + return + end if + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= czero).and.(rowlevs(k) <= fill_in)) then + ! + ! Note: since U is scaled while copying it out (see iluk_copyout), + ! we can use rwk in the update below + ! + rwk = row(k) + lrwk = rowlevs(k) + + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Insert the index into the heap for further processing. + ! The fill levels are initialized to a negative value. If we find + ! one, it means that it is an as yet untouched index, so we need + ! to insert it; otherwise it is already on the heap, there is no + ! need to insert it more than once. + ! + if (rowlevs(j)<0) then + call heap%insert(j,info) + if (info /= psb_success_) return + rowlevs(j) = abs(rowlevs(j)) + end if + ! + ! Update row(j) and the corresponding fill level + ! + row(j) = row(j) - rwk * val(jj) + rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1) + end do + + end if + end do + +end subroutine psb_cinvk_inv diff --git a/prec/impl/psb_c_invt_fact.f90 b/prec/impl/psb_c_invt_fact.f90 new file mode 100644 index 00000000..73e242f6 --- /dev/null +++ b/prec/impl/psb_c_invt_fact.f90 @@ -0,0 +1,739 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! + +subroutine psb_c_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + + use psb_base_mod + use psb_c_invt_fact_mod, psb_protect_name => psb_c_invt_bld + use psb_c_ilu_fact_mod + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_spk_), intent(in) :: thresh + real(psb_spk_), intent(in) :: invthresh + type(psb_cspmat_type), intent(inout) :: lmat, umat + complex(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_cspmat_type) :: atmp + complex(psb_spk_), allocatable :: pq(:), pd(:), w(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + real(psb_spk_) :: sp_thresh + character(len=20) :: name, ch_err, fname + + + info = psb_success_ + name='psb_cinvt_fact' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),w(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + if (info == 0) call psb_ilut_fact(nzrmax,sp_thresh,& + & a,lmat,umat,pd,info,blck=blck,iscale=psb_ilu_scale_maxval_) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (.false.) then +!!$ if (debug_level >= psb_debug_inner_) then + write(fname,'(a,i0,a)') 'invt-lo-',me,'.mtx' + call lmat%print(fname,head="INVTLOW") + write(fname,'(a,i0,a)') 'invt-up-',me,'.mtx' + call umat%print(fname,head="INVTUPP") + end if + + ! + ! Compute the approx U^-1 and L^-1 + ! + nzrmax = invfill + call psb_csparse_invt(n_row,umat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_csparse_invt(n_row,lmat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_invt_bld + +subroutine psb_csparse_invt(n,a,z,nzrmax,sp_thresh,info) + + use psb_base_mod + use psb_c_invt_fact_mod, psb_protect_name => psb_csparse_invt + + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:),jz(:) + complex(psb_spk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + complex(psb_spk_), allocatable :: row(:) + type(psb_c_coo_sparse_mat) :: trw + type(psb_c_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx, nlw,nup,jmaxup + type(psb_i_heap) :: heap + real(psb_spk_) :: alpha, nrmi + character(len=20) :: name='psb_sp_invt' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call zcsr%allocate(n,n,n*nzrmax) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + ! + ! + nzz = 0 + row(:) = czero + rowlevs(:) = 0 + l2 = 0 + zcsr%irp(1) = 1 + + outer: do i = 1, n-1 + ! ZW = e_i + call psb_c_invt_copyin(i,n,acsr,i,ione,n,nlw,nup,jmaxup,nrmi,row,& + & heap,rowlevs,ktrw,trw,info,sign=-sone) + if (info /= 0) exit + row(i) = cone + ! Adjust norm + if (nrmi < sone) then + nrmi = sqrt(sone + nrmi**2) + else + nrmi = nrmi*sqrt(cone+cone/(nrmi**2)) + end if + + call psb_invt_inv(sp_thresh,i,nrmi,row,heap,rowlevs,& + & acsr%ja,acsr%irp,acsr%val,nidx,idxs,info) + if (info /= 0) exit +!!$ write(0,*) 'Calling copyout ',nzrmax,nlw,nup,nidx,l2 + call psb_c_invt_copyout(nzrmax,sp_thresh,i,n,nlw,nup,jmaxup,nrmi,row,& + & nidx,idxs,l2,zcsr%ja,zcsr%irp,zcsr%val,info) + if (info /= 0) exit + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = cone + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_csparse_invt + +subroutine psb_c_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_d_invt_copyin + implicit none + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(inout) :: nrmi + complex(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), intent(in), optional :: sign + ! + integer(psb_ipk_) :: k,j,irb,kin,nz, err_act + integer(psb_ipk_), parameter :: nrb=16 + real(psb_dpk_) :: dmaxup, sign_ + real(psb_dpk_), external :: dnrm2 + character(len=20), parameter :: name='invt_copyin' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + sign_ = sone + if (present(sign)) sign_ = sign + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = czero + nrmi = czero + + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + call heap%insert(k,info) + irwt(k) = 1 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end do + nz = a%irp(i+1) - a%irp(i) + nrmi = dnrm2(nz,a%val(a%irp(i):),ione) + + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_invt_copyin + +subroutine psb_c_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + + use psb_base_mod + use psb_c_invt_fact_mod, psb_protect_name => psb_c_invt_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_spk_), intent(in) :: thres,nrmi + complex(psb_spk_),allocatable, intent(inout) :: val(:) + complex(psb_spk_), intent(inout) :: row(:) + + ! Local variables + real(psb_dpk_),allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + real(psb_dpk_) :: witem, wmin + integer(psb_ipk_) :: widx + integer(psb_ipk_) :: k,isz,err_act,int_err(5),idxp, nz + type(psb_d_idx_heap) :: heap + character(len=20), parameter :: name='invt_copyout' + character(len=20) :: ch_err + logical :: fndmaxup + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + ! + ! Here we need to apply also the dropping rule base on the fill-in. + ! We do it by putting into a heap the elements that are not dropped + ! by using the 2-norm rule, and then copying them out. + ! + ! The heap goes down on the entry absolute value, so the first item + ! is the largest absolute value. + ! +!!$ write(0,*) 'invt_copyout ',nidx,nup+fill_in + call heap%init(info,dir=psb_asort_down_) + + if (info == psb_success_) allocate(xwid(nidx),xw(nidx),indx(nidx),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/3*nidx/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + ! + ! First the lower part + ! + + nz = 0 + idxp = 0 + + do + + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + if (nz > 1) then + write(psb_err_unit,*) 'Warning: lower triangle from invt???? ' + end if + + + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + idxp = idxp - 1 + nz = 0 + wmin=HUGE(wmin) + if (.false.) then + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if ((widx/=jmaxup).and.(nz > nup+fill_in)) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if (nz > nup+fill_in) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz > nup+fill_in) then + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + end do + end if + end if + + ! + ! Now we put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the upper part of the row + ! + do k=1,nz + l2 = l2 + 1 + if (size(val) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,val,info) + if (info == psb_success_) call psb_realloc(isz,ja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + ja(l2) = xwid(k) + val(l2) = xw(indx(k)) + end do + + ! + ! Set row to zero + ! + do idxp=1,nidx + row(idxs(idxp)) = czero + end do + + irp(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_c_invt_copyout + +subroutine psb_c_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val,nidx,idxs,info) + + use psb_base_mod + use psb_c_invt_fact_mod, psb_protect_name => psb_c_invt_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: row(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + real(psb_dpk_) :: rwk, alpha + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + irwt(i) = 1 +!!$ write(0,*) 'Drop Threshold ',thres*nrmi + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! Should not happen, but just in case. + ! + if (k == lastk) cycle + lastk = k + + ! + ! Dropping rule based on the threshold: compare the absolute + ! value of each updated entry of row with thres * 2-norm of row. + ! + rwk = row(k) + + if (abs(rwk) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(k) = dzero + irwt(k) = 0 + cycle + else + ! + ! Note: since U is scaled while copying it out (see ilut_copyout), + ! we can use rwk in the update below. + ! + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Update row(j) and, if it is not to be discarded, insert + ! its index into the heap for further processing. + ! + row(j) = row(j) - rwk * val(jj) + if (irwt(j) == 0) then + if (abs(row(j)) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(j) = dzero + else + ! + ! Do the insertion. + ! + call heap%insert(j,info) + if (info /= psb_success_) return + irwt(j) = 1 + end if + end if + end do + end if + + ! + ! If we get here it is an index we need to keep on copyout. + ! + + nidx = nidx + 1 + call psb_ensure_size(nidx,idxs,info,addsz=psb_heap_resize) + if (info /= psb_success_) return + idxs(nidx) = k + irwt(k) = 0 + end do + + irwt(i) = 0 +end subroutine psb_c_invt_inv diff --git a/prec/impl/psb_c_prec_type_impl.f90 b/prec/impl/psb_c_prec_type_impl.f90 index e1f13fc4..e82d7dca 100644 --- a/prec/impl/psb_c_prec_type_impl.f90 +++ b/prec/impl/psb_c_prec_type_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,14 +27,14 @@ ! 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. -! -! -! +! +! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -46,7 +46,7 @@ !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific 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 @@ -58,14 +58,14 @@ !!$ 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. -!!$ -!!$ +!!$ +!!$ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine psb_c_apply2_vect(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_c_prec_type, psb_protect_name => psb_c_apply2_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_cprec_type), intent(inout) :: prec type(psb_c_vect_type),intent(inout) :: x @@ -74,9 +74,10 @@ subroutine psb_c_apply2_vect(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans complex(psb_spk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ complex(psb_spk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -84,28 +85,28 @@ subroutine psb_c_apply2_vect(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -114,13 +115,13 @@ subroutine psb_c_apply2_vect(prec,x,y,desc_data,info,trans,work) call prec%prec%apply(cone,x,czero,y,desc_data,info,& & trans=trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -135,7 +136,7 @@ end subroutine psb_c_apply2_vect subroutine psb_c_apply1_vect(prec,x,desc_data,info,trans,work) use psb_base_mod use psb_c_prec_type, psb_protect_name => psb_c_apply1_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_cprec_type), intent(inout) :: prec type(psb_c_vect_type),intent(inout) :: x @@ -144,9 +145,10 @@ subroutine psb_c_apply1_vect(prec,x,desc_data,info,trans,work) complex(psb_spk_),intent(inout), optional, target :: work(:) type(psb_c_vect_type) :: ww - character :: trans_ + character :: trans_ complex(psb_spk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -154,28 +156,28 @@ subroutine psb_c_apply1_vect(prec,x,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -186,13 +188,13 @@ subroutine psb_c_apply1_vect(prec,x,desc_data,info,trans,work) & trans=trans_,work=work_) if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info) call psb_gefree(ww,desc_data,info) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -207,7 +209,7 @@ end subroutine psb_c_apply1_vect subroutine psb_c_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_c_prec_type, psb_protect_name => psb_c_apply2v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_cprec_type), intent(inout) :: prec complex(psb_spk_),intent(inout) :: x(:) @@ -216,9 +218,10 @@ subroutine psb_c_apply2v(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans complex(psb_spk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ complex(psb_spk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -226,40 +229,40 @@ subroutine psb_c_apply2v(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=trans else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if call prec%prec%apply(cone,x,czero,y,desc_data,info,trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -274,7 +277,7 @@ end subroutine psb_c_apply2v subroutine psb_c_apply1v(prec,x,desc_data,info,trans) use psb_base_mod use psb_c_prec_type, psb_protect_name => psb_c_apply1v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_cprec_type), intent(inout) :: prec complex(psb_spk_),intent(inout) :: x(:) @@ -282,43 +285,42 @@ subroutine psb_c_apply1v(prec,x,desc_data,info,trans) character(len=1), optional :: trans character :: trans_ - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act complex(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_c_apply1v' info = psb_success_ call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if call prec%prec%apply(cone,x,czero,ww,desc_data,info,& & trans_,work=w1) if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if @@ -332,3 +334,159 @@ subroutine psb_c_apply1v(prec,x,desc_data,info,trans) end subroutine psb_c_apply1v +subroutine psb_ccprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_c_prec_type, psb_protect_name => psb_ccprecseti + implicit none + + class(psb_cprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precseti' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_FILLIN') + call prec%prec%precset(psb_ilu_fill_in_,val,info) + case ('INV_FILLIN') + call prec%prec%precset(psb_inv_fillin_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_ccprecseti + +subroutine psb_ccprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_c_prec_type, psb_protect_name => psb_ccprecsetr + implicit none + + class(psb_cprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetr' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case('SUB_ILUTHRS') + call prec%prec%precset(psb_fact_eps_,val,info) + case('INV_THRESH') + call prec%prec%precset(psb_inv_thresh_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_ccprecsetr + +subroutine psb_ccprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_c_prec_type, psb_protect_name => psb_ccprecsetc + implicit none + + class(psb_cprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetc' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_SOLVE') + ! We select here the type of solver on the block + select case (psb_toupper(trim(string))) + case("ILU") + call prec%prec%precset(psb_f_type_,psb_f_ilu_k_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + case("ILUT") + call prec%prec%precset(psb_f_type_,psb_f_ilu_t_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_t_,info) + case("AINV") + call prec%prec%precset(psb_f_type_,psb_f_ainv_,info) + case("INVK") + call prec%prec%precset(psb_f_type_,psb_f_invk_,info) + case("INVT") + call prec%prec%precset(psb_f_type_,psb_f_invt_,info) + case default + ! Default to ILU(0) factorization + call prec%prec%precset(psb_f_type_,psb_f_ilu_n_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + end select + case ("ILU_ALG") + select case (psb_toupper(trim(string))) + case ("MILU") + call prec%prec%precset(psb_ilu_ialg_,psb_milu_n_,info) + case default + ! Do nothing + end select + case ("ILUT_SCALE") + select case (psb_toupper(trim(string))) + case ("MAXVAL") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_maxval_,info) + case ("DIAG") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_diag_,info) + case ("ARWSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arwsum_,info) + case ("ARCSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arcsum_,info) + case ("ACLSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_aclsum_,info) + case ("NONE") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + case default + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + end select + case ("AINV_ALG") + select case (psb_toupper(trim(string))) + case("LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + case("SYM-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_llk_,info) + case("STAB-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_ft_llk_,info) + case("MLK","LMX") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_mlk_,info) + case default + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + end select + case default + + end select + +end subroutine psb_ccprecsetc diff --git a/prec/impl/psb_c_sp_drop.f90 b/prec/impl/psb_c_sp_drop.f90 new file mode 100644 index 00000000..fda59cc7 --- /dev/null +++ b/prec/impl/psb_c_sp_drop.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_c_sp_drop(idiag,nzrmax,sp_thresh,nz,iz,valz,info) + use psb_base_mod + implicit none + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, nzrmax + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: iz(:) + complex(psb_spk_), intent(inout) :: valz(:) + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i, j, idf, nw + complex(psb_spk_) :: witem + integer(psb_ipk_) :: widx + complex(psb_spk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + + if (nz > min(size(iz),size(valz))) then + write(0,*) 'Serious size problem ',nz,size(iz),size(valz) + info = -2 + return + end if + allocate(xw(nz),xwid(nz),indx(nz),stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory allocation failure in sp_drop',nz,info + return + endif + + ! Always keep the diagonal element + idf = -1 + do i=1, nz + if (iz(i) == idiag) then + idf = i + witem = valz(i) + widx = iz(i) + valz(i) = valz(1) + iz(i) = iz(1) + valz(1) = witem + iz(1) = widx + exit + end if + end do + + if (idf == -1) then + + xw(1:nz) = valz(1:nz) + call psb_qsort(xw(1:nz),indx(1:nz),dir=psb_asort_down_) + do i=1, nz + xwid(i) = iz(indx(i)) + end do + nw = min(nz,nzrmax) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + nw = max(nw, 1) + + else + + nw = nz-1 + + xw(1:nw) = valz(2:nz) + + call psb_qsort(xw(1:nw),indx(1:nw),dir=psb_asort_down_) + nw = min(nw,nzrmax-1) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + + do i=1, nw + xwid(i) = iz(1+indx(i)) + end do + nw = nw + 1 + xw(nw) = valz(1) + xwid(nw) = iz(1) + end if + + call psb_msort(xwid(1:nw),indx(1:nw),dir=psb_sort_up_) + + do i=1, nw + valz(i) = xw(indx(i)) + iz(i) = xwid(i) + end do + nz = nw + if (nz>nzrmax) write(0,*) 'in sp_drop: ',nw,nzrmax,nz + deallocate(xw,xwid,indx,stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory deallocation failure in sp_drop',info + return + endif + return +end subroutine psb_c_sp_drop diff --git a/prec/impl/psb_c_sparsify.f90 b/prec/impl/psb_c_sparsify.f90 new file mode 100644 index 00000000..4962f337 --- /dev/null +++ b/prec/impl/psb_c_sparsify.f90 @@ -0,0 +1,260 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_c_sparsify(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,info,istart,iheap,ikr) + use psb_base_mod + implicit none + + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + complex(psb_spk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_spk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: istart + type(psb_i_heap), optional :: iheap + integer(psb_ipk_), optional :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k + complex(psb_spk_) :: witem + integer(psb_ipk_) :: widx + complex(psb_spk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + type(psb_c_idx_heap) :: heap + + + info = psb_success_ + istart_ = 1 + if (present(istart)) istart_ = max(1,istart) + if (.false.) then + nz = 0 + do i=istart_, n + if ((i == idiag).or.(abs(zw(i)) >= sp_thresh)) then + nz = nz + 1 + iz(nz) = i + valz(nz) = zw(i) + end if + end do + + else + allocate(xw(nzrmax),xwid(nzrmax),indx(nzrmax),stat=info) + if (info /= psb_success_) then + return + end if + + call heap%init(info,dir=psb_asort_down_) + + ! Keep at least the diagonal + nz = 0 + + if (present(iheap)) then + if (.not.(present(ikr))) then + write(psb_err_unit,*) 'Error: if IHEAP then also IKR' + info = -1 + return + end if + last_i = -1 + do + call iheap%get_first(i,iret) + if (iret < 0) exit + ! An index may have been put on the heap more than once. + if (i == last_i) cycle + last_i = i + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + ikr(i) = 0 + end do + + else + + do i=istart_, n + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + end do + end if + + k = 1 + do + if (k == nzrmax) exit + call heap%get_first(witem,widx,info) + if (info == -1) then + info = psb_success_ + exit + endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + k = k + 1 + xw(k) = witem + xwid(k) = widx + end do + call heap%free(info) + nz = k + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + end if + + return + +end subroutine psb_c_sparsify + + +subroutine psb_c_sparsify_list(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,lhead,listv,ikr,info) + use psb_base_mod + implicit none + + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + complex(psb_spk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_spk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: lhead, listv(:) + integer(psb_ipk_) :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k,current, next + complex(psb_spk_) :: witem + integer(psb_ipk_) :: widx + complex(psb_spk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + istart_ = 1 + allocate(xw(n),xwid(n),indx(n),stat=info) + + current = lhead + lhead = -1 + i = 0 + do while (current >0) + i = i + 1 + xw(i) = zw(current) + xwid(i) = current + + if (current == idiag) then + ! Bring the diagona into first position + witem = xw(1) + widx = xwid(1) + xw(1) = xw(i) + xwid(1) = xwid(i) + xw(i) = witem + xwid(i) = widx + end if + + zw(current) = dzero + ikr(current) = 0 + + next = listv(current) + listv(current) = -1 + current = next + end do + nz = i + if (nz > 2) call psb_hsort(xw(2:nz),ix=xwid(2:nz),& + & dir=psb_asort_down_,flag=psb_sort_keep_idx_) +!!$ write(0,*) 'Done first msort ' +!!$ write(0,*) ' after first msort for idiag ',idiag,' :',nz,sp_thresh +!!$ do i=1, nz +!!$ write(0,*) ' ',xwid(i),xw(i) +!!$ end do + + i = 2 + do while (i<=nz) + if (abs(xw(i)) < sp_thresh) exit + i = i + 1 + end do +!!$ write(0,*) 'NZ ',nz, i, nzrmax + nz = max(1,min(i-1,nzrmax)) + call psb_msort(xwid(1:nz),ix=indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'Done second msort ' + +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,i,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + return + +end subroutine psb_c_sparsify_list diff --git a/prec/impl/psb_cprecbld.f90 b/prec/impl/psb_cprecbld.f90 index 588ac84d..3c3bf8be 100644 --- a/prec/impl/psb_cprecbld.f90 +++ b/prec/impl/psb_cprecbld.f90 @@ -44,7 +44,8 @@ subroutine psb_cprecbld(a,desc_a,p,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local scalars - integer(psb_ipk_) :: ictxt, me,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err @@ -58,9 +59,9 @@ subroutine psb_cprecbld(a,desc_a,p,info,amold,vmold,imold) end if info = psb_success_ - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() diff --git a/prec/impl/psb_cprecinit.f90 b/prec/impl/psb_cprecinit.f90 index 9f0b4d68..63b4d51b 100644 --- a/prec/impl/psb_cprecinit.f90 +++ b/prec/impl/psb_cprecinit.f90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psb_cprecinit(ictxt,p,ptype,info) +subroutine psb_cprecinit(ctxt,p,ptype,info) use psb_base_mod use psb_c_prec_type, psb_protect_name => psb_cprecinit @@ -37,7 +37,7 @@ subroutine psb_cprecinit(ictxt,p,ptype,info) use psb_c_diagprec, only : psb_c_diag_prec_type use psb_c_bjacprec, only : psb_c_bjac_prec_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_cprec_type), intent(inout) :: p character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -50,7 +50,7 @@ subroutine psb_cprecinit(ictxt,p,ptype,info) if (info /= psb_success_) return end if - p%ictxt = ictxt + p%ctxt = ctxt select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NONE','NOPREC') diff --git a/prec/impl/psb_crwclip.f90 b/prec/impl/psb_crwclip.f90 new file mode 100644 index 00000000..ade1171f --- /dev/null +++ b/prec/impl/psb_crwclip.f90 @@ -0,0 +1,90 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_c_rwclip(nz,ia,ja,val,imin,imax,jmin,jmax) + use psb_base_mod + + implicit none + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: ia(*), ja(*) + complex(psb_spk_), intent(inout) :: val(*) + integer(psb_ipk_), intent(in) :: imin,imax,jmin,jmax + + integer(psb_ipk_) :: i,j + + j = 0 + do i=1, nz + if ((imin <= ia(i)).and.& + & (ia(i) <= imax).and.& + & (jmin <= ja(i)).and.& + & (ja(i) <= jmax) ) then + j = j + 1 + ia(j) = ia(i) + ja(j) = ja(i) + val(j) = val(i) + end if + end do + nz = j +end subroutine psb_c_rwclip diff --git a/prec/impl/psb_csparse_biconjg_llk.F90 b/prec/impl/psb_csparse_biconjg_llk.F90 new file mode 100644 index 00000000..98110cd1 --- /dev/null +++ b/prec/impl/psb_csparse_biconjg_llk.F90 @@ -0,0 +1,366 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_csparse_biconjg_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_c_ainv_tools_mod + use psb_c_biconjg_mod, psb_protect_name => psb_csparse_biconjg_llk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + complex(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + complex(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_c_csc_sparse_mat) :: ac + complex(psb_spk_) :: alpha + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = czero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = czero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = cone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = cone + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = czero + ! !$ end do + zval(i) = cone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then +!!$ write(0,*) i, ' Outer inserting ',ac%ia(j) + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! ! write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha + if (.false..or.(abs(alpha) > sp_thresh)) then +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_csparse_biconjg_llk_noth + + ! + ! Left-looking variant, with NO drop rule on p(i)/p(j) + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + complex(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + complex(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_c_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_orth_llk_noth' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = czero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = czero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = done + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = czero + ! !$ end do + zval(i) = done + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.true.) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.true.) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_csparse_biconjg_mlk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + complex(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:), hlist(:), bfr(:), rwlist(:) + complex(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, hlhead, li, mj, kkc, ifrst, ilst, rwhead + type(psb_i_heap) :: heap, rheap + type(psb_c_csc_sparse_mat) :: ac + complex(psb_spk_) :: alpha + character(len=20) :: name='psb_biconjg_mlk' + logical, parameter :: debug=.false., test_merge=.true. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n), & + & hlist(n),rwlist(n),bfr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = czero + hlist(i) = -1 + rwlist(i) = -1 + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = czero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = cone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = cone + nzw = 1 + + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = czero + ! !$ end do + zval(i) = cone + izkr(i) = 1 + rwhead = i + + hlhead = -1 + + kkc = 0 + ilst = ac%icp(i)-1 + ifrst = ac%icp(i) + do j = ac%icp(i+1)-1, ac%icp(i), -1 + if (ac%ia(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (.true..or.debug) then +!!$ write(0,*) 'Outer Before insertion : ',hlhead + call printlist(hlhead,hlist) + end if + if (kkc > 0) then +!!$ write(0,*) i,' Outer Inserting : ',kkc,':',ac%ia(ifrst:ilst) + + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + mj = hlhead + if (mj > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outer + + izcr(j) = 0 + if (j>=i) cycle outer + + if (debug) write(0,*) 'update loop, using row: ',j,i,mj + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha +!!$ write(0,*) ' Current list is : ',hlhead +!!$ call printlist(hlhead,hlist) +!!$ + + + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=z%icp(j) + ilst=z%icp(j+1)-1 + call hlmerge(rwhead,rwlist,z%ia(ifrst:ilst)) +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr +!!$ call hlmerge(rwhead,rwlist,(/kr/)) + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',ac%ia(ifrst:ilst) + end if + if (ilst >= ifrst) then +!!$ write(0,*) j,i,' Inner inserting ',ac%ia(ifrst:ilst) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outer + call a%csget(i,i,nzra,ia,ja,val,info) + call rwclip(nzra,ia,ja,val,ione,n,ione,n) + p(i) = psb_spge_dot(nzra,ja,val,zval) + if (abs(p(i)) < s_epstol) & + & p(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzz+nzrz, z%ia, info) + call psb_ensure_size(nzz+nzrz, z%val, info) + ipz1 = z%icp(i) + do j=1, nzrz + z%ia(ipz1 + j -1) = ia(j) + z%val(ipz1 + j -1) = val(j) + end do + z%icp(i+1) = ipz1 + nzrz + nzz = nzz + nzrz + + + ! WVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = czero + ! !$ end do + zval(i) = cone + izkr(i) = 1 + rwhead = i + hlhead = -1 + + kkc = 0 + ilst = a%irp(i)-1 + ifrst = a%irp(i) + do j = a%irp(i+1)-1, a%irp(i), -1 + if (a%ja(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (debug) then + write(0,*) 'Outer Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Outer Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + if (kkc > 0 ) then + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outerw: do + mj = hlhead + if (hlhead > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outerw + + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=w%icp(j) + ilst=w%icp(j+1)-1 + call hlmerge(rwhead,rwlist,w%ia(ifrst:ilst)) + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + if (debug) write(0,*) 'update loop, adding indices: ',& + & a%ja(a%irp(kr):a%irp(kr+1)-1) + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outerw + ip1 = ac%icp(i) + ip2 = ac%icp(i+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + if (abs(q(i)) < s_epstol) & + & q(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzw+nzrz, w%ia, info) + call psb_ensure_size(nzw+nzrz, w%val, info) + ipz1 = w%icp(i) + do j=1, nzrz + w%ia(ipz1 + j -1) = ia(j) + w%val(ipz1 + j -1) = val(j) + end do + w%icp(i+1) = ipz1 + nzrz + nzw = nzw + nzrz + + end do + +contains + + subroutine hlmerge(head,listv,vals) + integer(psb_ipk_), intent(inout) :: head, listv(:) + integer(psb_ipk_), intent(in) :: vals(:) + integer(psb_ipk_) :: i,j,k, lh, lv, nv, vv, flh, ph + + nv = size(vals) + lh = head + flh = -1 + lv = 1 + if ((head < 0).and.(nv > 0)) then + ! Adjust head if empty + head = vals(lv) + lv = lv + 1 + else if ((head > 0) .and. (nv >0)) then + ! Adjust head if first item less than it + if (head > vals(lv)) then + listv(vals(lv)) = head + head = vals(lv) + lv = lv + 1 + end if + end if + + lh = head + ph = lh + do while ((lh > 0) .and. (lv <= nv)) + if (lh == vals(lv)) then + lv = lv + 1 + else if (lh > vals(lv)) then + listv(vals(lv)) = lh + listv(ph) = vals(lv) + lh = vals(lv) + lv = lv + 1 + else + ph = lh + lh = listv(lh) + end if + end do + lh = ph + do while (lv <= nv) + listv(lh) = vals(lv) + lh = listv(lh) + lv = lv + 1 + end do + end subroutine hlmerge + + + subroutine printlist(head,listv) + integer(psb_ipk_), intent(in) :: head, listv(:) + integer(psb_ipk_) :: li + + li = head + do while (li > 0) + write(0,*) 'Item: ', li + li = listv(li) + end do + end subroutine printlist + +end subroutine psb_csparse_biconjg_mlk diff --git a/prec/impl/psb_csparse_biconjg_s_ft_llk.F90 b/prec/impl/psb_csparse_biconjg_s_ft_llk.F90 new file mode 100644 index 00000000..64af2ed5 --- /dev/null +++ b/prec/impl/psb_csparse_biconjg_s_ft_llk.F90 @@ -0,0 +1,414 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_csparse_biconjg_s_ft_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_c_ainv_tools_mod + use psb_c_biconjg_mod, psb_protect_name => psb_csparse_biconjg_s_ft_llk + + ! + ! Left-looking variant, stabilized i.e. product by A is applied + ! to compute the diagonal elements. + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + complex(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:),iww(:) + complex(psb_spk_), allocatable :: zval(:),val(:), q(:), ww(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj, nzww,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, nzrw + type(psb_i_heap) :: heap, rheap + type(psb_c_csc_sparse_mat) :: ac + complex(psb_spk_) :: alpha, tmpq,tmpq2 + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),iww(n),ww(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! Init pointers to: + ! ljr(i): last occupied column index within row I + ! izcr(i): first occupied row index within column I + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = czero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = czero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = cone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = cone + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = czero + ! !$ end do + zval(i) = cone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) lastj) then + lastj = j + exit inner + end if + end do inner + izcr(j) = 0 + if (j>=i) exit outer + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = w%icp(j) + ip2 = w%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_c_spvspm(cone,a,nzra,w%ia(ip1:ip2),w%val(ip1:ip2),& + & czero,nzww,iww,ww,info) + + p(i) = psb_spge_dot(nzww,iww,ww,zval) + + ipz1 = z%icp(j) + ipz2 = z%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-p(i)/p(j)) +!!$ write(0,*) ' p(i)/p(j) ',i,j,alpha,p(i),p(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) exit outerw + if (debug) write(0,*) 'update loop, using row: ',j + if (.false.) then + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + else + ip1 = z%icp(j) + ip2 = z%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_c_spmspv(cone,ac,nzra,z%ia(ip1:ip2),z%val(ip1:ip2),& + & czero,nzww,iww,ww,info) + + q(i) = psb_spge_dot(nzww,iww,ww,zval) + end if + + ipz1 = w%icp(j) + ipz2 = w%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-q(i)/q(j)) +!!$ write(0,*) ' q(i)/q(j) ',i,j,alpha,q(i),q(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_csparse_biconjg_s_llk + + ! + ! Left-looking variant SYMMETRIC/HERMITIAN A. You have been warned! + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + complex(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + complex(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw,kk + type(psb_i_heap) :: heap, rheap + type(psb_c_csc_sparse_mat) :: ac + complex(psb_spk_) :: alpha, zvalmax + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = czero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = czero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = cone + nzz = 1 + zvalmax = cone + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = czero + ! !$ end do + zval(i) = cone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.false..or.(abs(alpha) > sp_thresh)) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) +!!$ if (abs(zval(kr)) > 1e16) then +!!$ write(0,*) i,j,p(i),p(j),alpha,z%val(k),alpha*z%val(k),kr,zval(kr) +!!$ end if + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + iscale_ = psb_ilu_scale_none_ + if (present(iscale)) iscale_ = iscale + weight = done + ! + ! Check the memory available to hold the W and Z factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = desc%get_local_rows() + allocate(pq(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + ! + ! Ok, let's start first with Z (i.e. Upper) + ! + call a%csclip(acoo,info,imax=n_row,jmax=n_row) + call acsr%mv_from_coo(acoo,info) + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + + case(psb_ilu_scale_maxval_) + weight = acsr%maxval() + weight = done/weight + call acsr%scal(weight,info) + + case(psb_ilu_scale_arcsum_) + allocate(arws(n_row),acls(n_row),ad(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + call acsr%arwsum(arws) + call acsr%aclsum(acls) + ad(1:n_row) = sqrt(sqrt(arws(1:n_row)*acls(1:n_row))) + ad(1:n_row) = done/ad(1:n_row) + call acsr%scal(ad,info,side='L') + call acsr%scal(ad,info,side='R') + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + ! + ! Here for the actual workhorses. + ! Only biconjg is surviving for now.... + ! + call psb_sparse_biconjg(alg,n_row,acsr,pq,& + & zmat,wmat,nzrmax,sp_thresh,info) + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparse_biconjg') + goto 9999 + end if + call atmp%mv_from(acsr) + + ! + ! Is this right??? + ! + do i=1, n_row + if (abs(pq(i)) < d_epstol) then + pq(i) = done + else + pq(i) = done/pq(i) + end if + end do + + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + case(psb_ilu_scale_maxval_) + pq(:) = pq(:)*weight + + case(psb_ilu_scale_arcsum_) + call zmat%scal(ad,info,side='L') + call wmat%scal(ad,info,side='R') + + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + call psb_move_alloc(pq,d,info) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_ainv_bld diff --git a/prec/impl/psb_d_bjacprec_impl.f90 b/prec/impl/psb_d_bjacprec_impl.f90 index ef8c52c3..0cb0bdb9 100644 --- a/prec/impl/psb_d_bjacprec_impl.f90 +++ b/prec/impl/psb_d_bjacprec_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,28 +27,29 @@ ! 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. -! -! +! +! subroutine psb_d_bjac_dump(prec,info,prefix,head) use psb_base_mod use psb_d_bjacprec, psb_protect_name => psb_d_bjac_dump - implicit none + implicit none class(psb_d_bjac_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than - ! len of prefix_ + ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) - if (present(prefix)) then + if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) else prefix_ = "dump_fact_d" @@ -73,7 +74,7 @@ end subroutine psb_d_bjac_dump subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_d_bjacprec, psb_protect_name => psb_d_bjac_apply_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_d_bjac_prec_type), intent(inout) :: prec real(psb_dpk_),intent(in) :: alpha,beta @@ -87,7 +88,8 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) integer(psb_ipk_) :: n_row,n_col real(psb_dpk_), pointer :: ww(:), aux(:) type(psb_d_vect_type) :: wv, wv1 - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit logical :: do_alloc_wrk @@ -99,8 +101,8 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -116,12 +118,12 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (x%get_nrows() < n_row) then + if (x%get_nrows() < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (y%get_nrows() < n_row) then + if (y%get_nrows() < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -138,9 +140,9 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) @@ -150,19 +152,19 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) allocate(ww(n_col),aux(4*n_col),stat=info) endif - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if do_alloc_wrk = .not.prec%is_allocated_wrk() if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate (wv => prec%wrk(1), wv1 => prec%wrk(2)) - + select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) + select case(trans_) case('N') call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,wv,desc_data,info,& @@ -170,31 +172,58 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + case('T') call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,& & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + case('C') - + call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,wv,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + call wv1%mlt(done,prec%dv,wv,dzero,info,conjgx=trans_) - + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv1,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + case('N') + call psb_spmm(done,prec%av(psb_l_pr_),x,dzero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + if (info == psb_success_) call wv1%mlt(done,prec%dv,wv,dzero,info) + if(info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1,& + & beta,y,desc_data,info, trans=trans_, work=aux,doswap=.false.) + + case('T','C') + call psb_spmm(done,prec%av(psb_l_pr_),x,dzero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + if (info == psb_success_) call wv1%mlt(done,prec%dv,wv,dzero,info) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1, & + & beta,y,desc_data,info,trans=trans_,work=aux,doswap=.false.) + end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if - + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') @@ -202,12 +231,12 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end select end associate - + call psb_halo(y,desc_data,info,data=psb_comm_mov_) if (do_alloc_wrk) call prec%free_wrk(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -229,7 +258,7 @@ end subroutine psb_d_bjac_apply_vect subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_d_bjacprec, psb_protect_name => psb_d_bjac_apply - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_d_bjac_prec_type), intent(inout) :: prec real(psb_dpk_),intent(in) :: alpha,beta @@ -242,7 +271,9 @@ subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) ! Local variables integer(psb_ipk_) :: n_row,n_col real(psb_dpk_), pointer :: ww(:), aux(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_d_vect_type) :: tx,ty + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit character :: trans_ @@ -253,8 +284,8 @@ subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -270,12 +301,12 @@ subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (size(x) < n_row) then + if (size(x) < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(y) < n_row) then + if (size(y) < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -292,29 +323,29 @@ subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) select case(trans_) case('N') @@ -341,11 +372,42 @@ subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) & trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + + case('N') + call psb_spmm(done,prec%av(psb_l_pr_),x,dzero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('T') + call psb_spmm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('C') + call psb_spmm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * (prec%dv%v%v(1:n_row)) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + end select + case default info = psb_err_internal_error_ @@ -355,8 +417,8 @@ subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_halo(y,desc_data,info,data=psb_comm_mov_) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -394,11 +456,26 @@ subroutine psb_d_bjac_precinit(prec,info) call psb_Errpush(info,name) goto 9999 end if + call psb_realloc(psb_rfpsz,prec%rprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if prec%iprcparm(:) = 0 prec%iprcparm(psb_p_type_) = psb_bjac_ prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ prec%iprcparm(psb_ilu_fill_in_) = 0 + prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_ + prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_ + prec%iprcparm(psb_inv_fillin_) = 0 + prec%iprcparm(psb_ainv_alg_) = psb_ainv_llk_ + + + prec%rprcparm(:) = 0 + prec%rprcparm(psb_fact_eps_) = 1E-1_psb_dpk_ + prec%rprcparm(psb_inv_thresh_) = 1E-1_psb_dpk_ call psb_erractionrestore(err_act) @@ -413,7 +490,8 @@ end subroutine psb_d_bjac_precinit subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct + use psb_d_ilu_fact_mod + use psb_d_ainv_fact_mod use psb_d_bjacprec, psb_protect_name => psb_d_bjac_precbld Implicit None @@ -425,14 +503,16 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) class(psb_d_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold - ! .. Local Scalars .. - integer(psb_ipk_) :: i, m + ! .. Local Scalars .. + integer(psb_ipk_) :: i, m, ialg, fill_in, iscale, inv_fill, iinvalg integer(psb_ipk_) :: ierr(5) character :: trans, unitd - type(psb_d_csr_sparse_mat), allocatable :: lf, uf + type(psb_dspmat_type), allocatable :: lf, uf real(psb_dpk_), allocatable :: dd(:) + real(psb_dpk_) :: fact_eps, inv_thresh integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me character(len=20) :: name='d_bjac_precbld' character(len=20) :: ch_err @@ -444,9 +524,9 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_ctxt() - call prec%set_ctxt(ictxt) - call psb_info(ictxt, me, np) + ctxt=desc_a%get_ctxt() + call prec%set_ctxt(ctxt) + call psb_info(ctxt, me, np) m = a%get_nrows() if (m < 0) then @@ -458,19 +538,100 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) trans = 'N' unitd = 'U' + ! We check if all the information contained in the preconditioner structure + ! are meaningful, otherwise we give an error and get out of the build + ! procedure + ialg = prec%iprcparm(psb_ilu_ialg_) ! Integer for ILU type algorithm + iinvalg = prec%iprcparm(psb_ainv_alg_) ! Integer for AINV type algorithm + iscale = prec%iprcparm(psb_ilu_scale_) ! Integer for scaling of matrix + fact_eps = prec%rprcparm(psb_fact_eps_) ! Drop-tolerance for factorization + inv_thresh = prec%rprcparm(psb_inv_thresh_) ! Drop-tolerance for inverse + fill_in = prec%iprcparm(psb_ilu_fill_in_) ! Fill-In for factorization + inv_fill = prec%iprcparm(psb_inv_fillin_) ! Fill-In for inverse factorization + + ! Check if the type of scaling is known, pay attention that not all the + ! scalings make sense for all the factorization, if something that does not + ! make sense is required the factorization routine will fail in an + ! unnrecoverable way. + if ((iscale == psb_ilu_scale_none_).or.& + (iscale == psb_ilu_scale_maxval_).or.& + (iscale == psb_ilu_scale_diag_).or.& + (iscale == psb_ilu_scale_arwsum_).or.& + (iscale == psb_ilu_scale_aclsum_).or.& + (iscale == psb_ilu_scale_arcsum_)) then + ! Do nothing: admissible request + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_scale_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the variant for the AINV is known to the library + if( (prec%iprcparm(psb_f_type_) == psb_f_ainv_).and.(& + & (iinvalg == psb_ainv_llk_).or.(iinvalg == psb_ainv_s_llk_).or. & + & (iinvalg == psb_ainv_s_ft_llk_).or.(iinvalg == psb_ainv_llk_noth_).or.& + & (iinvalg == psb_ainv_mlk_).or.(iinvalg == psb_ainv_lmx_ ) ) ) then + ! Do nothing, these are okay + else + info=psb_err_from_subroutine_ + ch_err='psb_ainv_alg_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the drop-tolerance make sense, if fact_eps > 1 and we are requiring + ! either ILUT, or INVT we give an error. + if( (fact_eps > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ilu_t_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_fact_eps_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! It the drop-tolerance for the inverse factors, inv_thresh > 1 and we are + ! requiring AINV or, or INVT we give an error + if( (inv_thresh > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ainv_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_inv_thresh_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Checks relative to the fill-in parameters + if (prec%iprcparm(psb_f_type_) == psb_f_ilu_n_) then + if(fill_in < 0) then + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fill_in_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + else if (fill_in == 0) then + ! If the requested level of fill is equal to zero, we default to the + ! specialized ILU(0) routine + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + end if + end if + ! If no limit on the fill_in is required we allow every fill, this is needed + ! since this quantity is used to allocate the auxiliary vectors for the + ! factorization + if (inv_fill <= 0) inv_fill = m + + ! Select on the type of factorization to be used select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_) + ! ILU(0) Factorization: the total number of nonzeros of the factorized matrix + ! is equal to the one of the input matrix - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) call prec%av(i)%free() enddo deallocate(prec%av,stat=info) endif end if - if (.not.allocated(prec%av)) then + if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -497,27 +658,27 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) end if allocate(dd(n_row),stat=info) - if (info == psb_success_) then + if (info == psb_success_) then allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) end if end if end if - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) + ! This is where we have no renumbering, thus no need + call psb_ilu0_fact(ialg,a,lf,uf,dd,info) if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) call prec%av(psb_l_pr_)%set_asb() call prec%av(psb_u_pr_)%set_asb() call prec%av(psb_l_pr_)%trim() @@ -526,12 +687,375 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) ! call move_alloc(dd,prec%d) else info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' + ch_err='psb_ilu0_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(psb_f_none_) + case(psb_f_ilu_k_) + ! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on + ! the type of the variant of the algorithm the may be forgotten or added to + ! the diagonal (MILU) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ilu_t_) + ! ILU(N,E) Incomplete LU factorization with thresholding and level of fill + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ainv_) + ! Approximate Inverse Factorizations based on variants of the incomplete + ! biconjugation algorithms + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_ainv_fact(a,iinvalg,inv_fill,inv_thresh,lf,dd,uf,desc_a,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invk_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(n) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invk_fact(a,fill_in, inv_fill,lf,dd,uf,desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invt_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(eps) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_d_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invt_fact(a,fill_in,inv_fill,fact_eps,inv_thresh,lf,dd,uf,& + & desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) @@ -544,7 +1068,7 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) goto 9999 end select - if (present(amold)) then + if (present(amold)) then call prec%av(psb_l_pr_)%cscnv(info,mold=amold) call prec%av(psb_u_pr_)%cscnv(info,mold=amold) end if @@ -563,8 +1087,8 @@ subroutine psb_d_bjac_precseti(prec,what,val,info) Implicit None class(psb_d_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='d_bjac_precset' @@ -572,34 +1096,33 @@ subroutine psb_d_bjac_precseti(prec,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(prec%iprcparm)) then + if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_f_type_) prec%iprcparm(psb_f_type_) = val - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_ilu_fill_in_) prec%iprcparm(psb_ilu_fill_in_) = val + case (psb_ilu_ialg_) + prec%iprcparm(psb_ilu_ialg_) = val + + case (psb_ilu_scale_) + prec%iprcparm(psb_ilu_scale_) = val + + case (psb_ainv_alg_) + prec%iprcparm(psb_ainv_alg_) = val + + case(psb_inv_fillin_) + prec%iprcparm(psb_inv_fillin_) = val + case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what end select @@ -609,3 +1132,45 @@ subroutine psb_d_bjac_precseti(prec,what,val,info) 9999 call psb_error_handler(err_act) return end subroutine psb_d_bjac_precseti + +subroutine psb_d_bjac_precsetr(prec,what,val,info) + + use psb_base_mod + use psb_d_bjacprec, psb_protect_name => psb_d_bjac_precsetr + Implicit None + + class(psb_d_bjac_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, nrow + character(len=20) :: name='d_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%rprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + + case (psb_fact_eps_) + prec%rprcparm(psb_fact_eps_) = val + + case (psb_inv_thresh_) + prec%rprcparm(psb_inv_thresh_) = val + + case default + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_bjac_precsetr diff --git a/prec/impl/psb_d_diagprec_impl.f90 b/prec/impl/psb_d_diagprec_impl.f90 index 5e0175a2..8c7e560c 100644 --- a/prec/impl/psb_d_diagprec_impl.f90 +++ b/prec/impl/psb_d_diagprec_impl.f90 @@ -38,15 +38,16 @@ subroutine psb_d_diag_dump(prec,info,prefix,head) integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/impl/psb_d_ilu0_fact.f90 b/prec/impl/psb_d_ilu0_fact.f90 index 4ec9ffb1..478eedfa 100644 --- a/prec/impl/psb_d_ilu0_fact.f90 +++ b/prec/impl/psb_d_ilu0_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_dilu0_fact.f90 ! ! Subroutine: psb_dilu0_fact @@ -75,7 +75,7 @@ ! ! This routine computes either the ILU(0) or the MILU(0) factorization of ! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a given level of a ! multilevel preconditioner. ! @@ -83,10 +83,10 @@ ! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, ! SIAM, 2003, Chapter 10. ! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is CSR. +! The diagonal of the U factor is stored separately (actually, the inverse of the +! diagonal entries is stored; this is then managed in the solve stage associated ! to the ILU(0)/MILU(0) factorization). ! ! The routine copies and factors "on the fly" from a and blck into l (L factor), @@ -94,7 +94,7 @@ ! ! This implementation of ILU(0)/MILU(0) is faster than the implementation in ! psb_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! +! ! ! Arguments: ! ialg - integer, input. @@ -121,7 +121,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_dspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -129,7 +129,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. -! +! subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) use psb_base_mod @@ -157,30 +157,30 @@ subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(upd)) then - upd_ = psb_toupper(upd) + if (present(upd)) then + upd_ = psb_toupper(upd) else upd_ = 'F' end if - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -212,12 +212,12 @@ subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() if(info.ne.0) then @@ -226,7 +226,7 @@ subroutine psb_dilu0_fact(ialg,a,l,u,d,info,blck, upd) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - deallocate(blck_) + deallocate(blck_) endif call psb_erractionrestore(err_act) @@ -243,9 +243,9 @@ contains ! Version: real ! Note: internal subroutine of psb_dilu0_fact. ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' ! (block-Jacobi preconditioner/solver, Additive Schwarz ! preconditioner) corresponding to a given level of a multilevel preconditioner. ! @@ -257,7 +257,7 @@ contains ! ! The routine copies and factors "on the fly" from the sparse matrix structures a ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! + ! ! ! Arguments: ! ialg - integer, input. @@ -296,7 +296,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - real(psb_dpk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -305,18 +305,18 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output. ! The number of nonzero entries in lval. ! l2 - integer, output. ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_dilu0_factint(ialg,a,b,& & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: ialg @@ -332,7 +332,7 @@ contains real(psb_dpk_) :: dia,temp integer(psb_ipk_), parameter :: nrb=16 type(psb_d_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: int_err(5) character(len=20) :: name, ch_err name='psb_dilu0_factint' @@ -346,10 +346,10 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione,ialg,izero,izero,izero/)) goto 9999 end select @@ -363,7 +363,7 @@ contains end if m = ma+mb - if (psb_toupper(upd) == 'F' ) then + if (psb_toupper(upd) == 'F' ) then lirp(1) = 1 uirp(1) = 1 l1 = 0 @@ -379,14 +379,14 @@ contains if (i <= ma) then ! ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval + ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) else ! ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval + ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) @@ -437,7 +437,7 @@ contains ! dia = dia - temp*uval(jj) cycle updateloop - ! + ! else if (j > i) then ! ! search u(i,*) (i-th row of U) for a matching index j @@ -454,23 +454,23 @@ contains end if enddo end if - ! - ! If we get here we missed the cycle updateloop, which means + ! + ! If we get here we missed the cycle updateloop, which means ! that this entry does not match; thus we accumulate on the ! diagonal for MILU(0). ! - if (ialg == psb_milu_n_) then + if (ialg == psb_milu_n_) then dia = dia - temp*uval(jj) end if enddo updateloop enddo - ! + ! ! Check the pivot size - ! + ! if (abs(dia) < d_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') abs(dia) @@ -493,7 +493,7 @@ contains else write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 @@ -515,7 +515,7 @@ contains ! Version: real ! Note: internal subroutine of psb_dilu0_fact ! - ! This routine copies a row of a sparse matrix A, stored in the psb_dspmat_type + ! This routine copies a row of a sparse matrix A, stored in the psb_dspmat_type ! data structure a, into the arrays lval and uval and into the scalar variable ! dia, corresponding to the lower and upper triangles of A and to the diagonal ! entry of the row, respectively. The entries in lval and uval are stored @@ -529,14 +529,14 @@ contains ! ! The routine is used by psb_dilu0_factint in the computation of the ILU(0)/MILU(0) ! factorization of a local sparse matrix. - ! + ! ! TODO: modify the routine to allow copying into output L and U that are ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! then use the ILU(0) internal for subsequent calls with the same pattern. ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -570,13 +570,13 @@ contains ! to the CSR storage format. ! uval - real(psb_dpk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the - ! upper triangle are copied. + ! upper triangle are copied. ! ktrw - integer, input/output. ! The index identifying the last entry taken from the ! staging buffer trw. See below. ! trw - type(psb_dspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -608,10 +608,10 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - if (psb_toupper(upd) == 'F') then + if (psb_toupper(upd) == 'F') then - select type(aa => a%a) - type is (psb_d_csr_sparse_mat) + select type(aa => a%a) + type is (psb_d_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format @@ -633,19 +633,19 @@ contains end if enddo - class default + class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into lval, dia, uval, through ! successive calls to ilu_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) + call aa%csget(i,i+irb-1,trw,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='csget' @@ -656,7 +656,7 @@ contains end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) @@ -680,7 +680,7 @@ contains write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 diff --git a/prec/impl/psb_d_iluk_fact.f90 b/prec/impl/psb_d_iluk_fact.f90 index 6d644e42..544ec987 100644 --- a/prec/impl/psb_d_iluk_fact.f90 +++ b/prec/impl/psb_d_iluk_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_diluk_fact.f90 ! ! Subroutine: psb_diluk_fact @@ -74,7 +74,7 @@ ! Contains: psb_diluk_factint, iluk_copyin, iluk_fact, iluk_copyout. ! ! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to +! diagonal blocks of a distributed matrix. These factorizations are used to ! build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a certain level of a ! multilevel preconditioner. @@ -88,7 +88,7 @@ ! U factors is CSR. The diagonal of the U factor is stored separately (actually, ! the inverse of the diagonal entries is stored; this is then managed in the solve ! stage associated to the ILU(k)/MILU(k) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -118,7 +118,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_dspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -126,7 +126,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_base_mod @@ -143,7 +143,7 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) real(psb_dpk_), intent(inout) :: d(:) ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act - + type(psb_dspmat_type), pointer :: blck_ type(psb_d_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -152,17 +152,17 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -170,7 +170,7 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -203,15 +203,15 @@ subroutine psb_diluk_fact(fill_in,ialg,a,l,u,d,info,blck) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -280,7 +280,7 @@ contains ! according to the CSR storage format. ! lia2 - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. + ! of the L factor in laspk, according to the CSR storage format. ! uval - real(psb_dpk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -289,12 +289,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in laspk. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_diluk_factint(fill_in,ialg,a,b,& @@ -304,7 +304,7 @@ contains implicit none - ! Arguments + ! Arguments integer(psb_ipk_), intent(in) :: fill_in, ialg type(psb_dspmat_type),intent(in) :: a,b integer(psb_ipk_),intent(inout) :: l1,l2,info @@ -330,14 +330,14 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,& & i_err=(/itwo,ialg,izero,izero,izero/)) goto 9999 end select - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) @@ -349,7 +349,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the iluk_copyin function + ! Allocate a temporary buffer for the iluk_copyin function ! call trw%allocate(izero,izero,ione) @@ -361,7 +361,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -381,34 +381,34 @@ contains uplevs(:) = m+1 row(:) = dzero rowlevs(:) = -(m+1) - + ! ! Cycle over the matrix rows ! do i = 1, m - + ! ! At each iteration of the loop we keep in a heap the column indices ! affected by the factorization. The heap is initialized and filled ! in the iluk_copyin routine, and updated during the elimination, in ! the iluk_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = dzero if (i<=ma) then ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) else ! ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! + ! (as (i-ma)-th row) + ! call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) endif - + ! Do an elimination step on the current row. It turns out we only ! need to keep track of fill levels for the upper triangle, hence we ! do not have a lowlevs variable. @@ -417,7 +417,7 @@ contains & d,uja,uirp,uval,uplevs,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) if (info /= psb_success_) then @@ -474,11 +474,11 @@ contains ! ! This routine is used by psb_diluk_factint in the computation of the ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -510,7 +510,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_dspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -521,8 +521,8 @@ contains use psb_base_mod implicit none - - ! Arguments + + ! Arguments type(psb_dspmat_type), intent(in) :: a type(psb_d_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i,m,jmin,jmax @@ -542,17 +542,17 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - call heap%init(info) + call heap%init(info) - select type (aa=> a%a) - type is (psb_d_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_d_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! - + do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) rowlevs(k) = 0 call heap%insert(k,info) @@ -562,14 +562,14 @@ contains class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to iluk_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -581,11 +581,11 @@ contains ktrw=1 end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) rowlevs(k) = 0 call heap%insert(k,info) @@ -674,10 +674,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i, fill_in integer(psb_ipk_), intent(inout) :: nidx,info integer(psb_ipk_), intent(inout) :: rowlevs(:) @@ -690,7 +690,7 @@ contains real(psb_dpk_) :: rwk info = psb_success_ - if (.not.allocated(idxs)) then + if (.not.allocated(idxs)) then allocate(idxs(200),stat=info) if (info /= psb_success_) return endif @@ -702,34 +702,34 @@ contains ! do ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) return - ! + ! ! Just in case an index has been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k nidx = nidx + 1 - if (nidx>size(idxs)) then + if (nidx>size(idxs)) then call psb_realloc(nidx+psb_heap_resize,idxs,info) if (info /= psb_success_) return end if idxs(nidx) = k - - if ((row(k) /= dzero).and.(rowlevs(k) <= fill_in).and.(ki) then + else if (j>i) then ! ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! ! Figure out a good reallocation size! ! isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -941,11 +941,11 @@ contains end if uja(l2) = j uval(l2) = row(j) - uplevs(l2) = rowlevs(j) + uplevs(l2) = rowlevs(j) else if (ialg == psb_milu_n_) then ! ! MILU(k): add discarded entries to the diagonal one - ! + ! d(i) = d(i) + row(j) end if ! @@ -963,13 +963,13 @@ contains lirp(i+1) = l1 + 1 uirp(i+1) = l2 + 1 - ! + ! ! Check the pivot size ! if (abs(d(i)) < d_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) diff --git a/prec/impl/psb_d_ilut_fact.f90 b/prec/impl/psb_d_ilut_fact.f90 index bcd26396..6c2dc698 100644 --- a/prec/impl/psb_d_ilut_fact.f90 +++ b/prec/impl/psb_d_ilut_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_dilut_fact.f90 ! ! Subroutine: psb_dilut_fact @@ -87,7 +87,7 @@ ! CSR. The diagonal of the U factor is stored separately (actually, the ! inverse of the diagonal entries is stored; this is then managed in the ! solve stage associated to the ILU(k,t) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -114,7 +114,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_dspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -122,9 +122,9 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - + use psb_base_mod use psb_d_ilu_fact_mod, psb_protect_name => psb_dilut_fact @@ -141,7 +141,7 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) integer(psb_ipk_), intent(in), optional :: iscale ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - + type(psb_dspmat_type), pointer :: blck_ type(psb_d_csr_sparse_mat) :: ll, uu real(psb_dpk_) :: scale @@ -151,34 +151,34 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) info = psb_success_ call psb_erractionsave(err_act) - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) goto 9999 end if - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(iscale)) then + if (present(iscale)) then iscale_ = iscale else iscale_ = psb_ilu_scale_none_ end if - - select case(iscale_) + + select case(iscale_) case(psb_ilu_scale_none_) scale = sone case(psb_ilu_scale_maxval_) @@ -189,10 +189,10 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) goto 9999 end select - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -225,15 +225,15 @@ subroutine psb_dilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -298,7 +298,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - real(psb_dpk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -307,12 +307,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in lval. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_dilut_factint(fill_in,thres,a,b,& @@ -320,7 +320,7 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: fill_in @@ -355,7 +355,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the ilut_copyin function + ! Allocate a temporary buffer for the ilut_copyin function ! call trw%allocate(izero,izero,ione) if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) @@ -366,7 +366,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -396,10 +396,10 @@ contains ! in the ilut_copyin function, and updated during the elimination, in ! the ilut_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = czero - if (i<=ma) then + if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& & row,heap,ktrw,trw,info) else @@ -414,7 +414,7 @@ contains & d,uja,uirp,uval,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) @@ -429,7 +429,7 @@ contains ! ! Adjust diagonal accounting for scale factor ! - if (weight /= sone) then + if (weight /= sone) then d(1:m) = d(1:m)*weight end if @@ -469,7 +469,7 @@ contains ! - storing into a heap the column indices of the nonzero entries of the copied ! row; ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; + ! in the part of the row belonging to the upper triangle; ! - computing the 2-norm of the row. ! The output array row is such that it contains a full row of A, i.e. it contains ! also the zero entries of the row. This is useful for the elimination step @@ -482,11 +482,11 @@ contains ! ! This routine is used by psb_dilut_factint in the computation of the ILU(k,t) ! factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -533,7 +533,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_dspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -542,7 +542,7 @@ contains subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& & nrmi,weight,row,heap,ktrw,trw,info) use psb_base_mod - implicit none + implicit none type(psb_dspmat_type), intent(in) :: a type(psb_d_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd @@ -584,29 +584,29 @@ contains dmaxup = szero nrmi = szero - select type (aa=> a%a) - type is (psb_d_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_d_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if end if end if end do - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 @@ -617,16 +617,16 @@ contains class default - + ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to ilut_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -639,18 +639,18 @@ contains kin = ktrw nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if @@ -734,10 +734,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i integer(psb_ipk_), intent(inout) :: nidx,info real(psb_dpk_), intent(in) :: thres,nrmi @@ -753,23 +753,23 @@ contains call psb_ensure_size(200*ione,idxs,info) if (info /= psb_success_) return nidx = 0 - lastk = -1 + lastk = -1 ! ! Do while there are indices to be processed ! do - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) exit - ! + ! ! An index may have been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k lowert: if (k nidx) exit if (idxs(idxp) >= i) exit @@ -987,8 +987,8 @@ contains ! if (abs(witem) < thres*nrmi) cycle - nz = nz + 1 - xw(nz) = witem + nz = nz + 1 + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1000,9 +1000,9 @@ contains ! ! Now we have to take out the first nlw+fill_in entries - ! + ! if (nz <= nlw+fill_in) then - ! + ! ! Just copy everything from xw, and it is already ordered ! else @@ -1014,7 +1014,7 @@ contains call psb_errpush(info,name,a_err='psb_heap_get_first') goto 9999 end if - + xw(k) = witem xwid(k) = widx end do @@ -1029,15 +1029,15 @@ contains ! Copy out the lower part of the row ! do k=1,nz - l1 = l1 + 1 + l1 = l1 + 1 if (size(lval) < l1) then - ! + ! ! Figure out a good reallocation size! - ! + ! isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -1046,25 +1046,25 @@ contains lja(l1) = xwid(k) lval(l1) = xw(indx(k)) end do - + ! ! Make sure idxp points to the diagonal entry ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do idxp = idxp + 1 if (idxp > nidx) exit if (idxs(idxp) >= i) exit end do end if end if - if (idxp > size(idxs)) then + if (idxp > size(idxs)) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' else - if (idxs(idxp) > i) then + if (idxs(idxp) > i) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then + else if (idxs(idxp) /= i) then !!$ write(0,*) 'Warning: impossible error: diagonal has vanished' else ! @@ -1076,7 +1076,7 @@ contains if (abs(d(i)) < d_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) @@ -1092,7 +1092,7 @@ contains end if ! - ! Now the upper part + ! Now the upper part ! call heap%init(info,dir=psb_asort_down_) @@ -1104,15 +1104,15 @@ contains nz = 0 do - + idxp = idxp + 1 if (idxp > nidx) exit widx = idxs(idxp) - if (widx <= i) then + if (widx <= i) then !!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) cycle end if - if (widx > m) then + if (widx > m) then !!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) cycle end if @@ -1120,12 +1120,12 @@ contains ! ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle end if nz = nz + 1 - xw(nz) = witem + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1133,7 +1133,7 @@ contains call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 end if - + end do ! @@ -1141,7 +1141,7 @@ contains ! we include entry jmaxup. ! if (nz <= nup+fill_in) then - ! + ! ! Just copy everything from xw ! fndmaxup=.true. @@ -1155,13 +1155,13 @@ contains if (widx == jmaxup) fndmaxup=.true. end do end if - if ((i psb_d_invk_bld + use psb_d_ilu_fact_mod + implicit none + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_dspmat_type), intent(inout) :: lmat, umat + real(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_dspmat_type) :: atmp + real(psb_dpk_), allocatable :: pq(:), pd(:) + integer(psb_ipk_), allocatable :: uplevs(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + character(len=20) :: name, ch_err + + + info = psb_success_ + name='psb_dinvk_bld' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + + call psb_iluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + !,uplevs=uplevs) + !call psb_diluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + ! + ! Compute the aprox U^-1 and L^-1 + ! + call psb_sparse_invk(n_row,umat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_sparse_invk(n_row,lmat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_invk_bld + +subroutine psb_dsparse_invk(n,a,z,fill_in,info,inlevs) + + use psb_base_mod + use psb_d_invk_fact_mod, psb_protect_name => psb_dsparse_invk + + integer(psb_ipk_), intent(in) :: n + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:), jz(:) + real(psb_dpk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:), idxs(:) + real(psb_dpk_), allocatable :: row(:) + type(psb_d_coo_sparse_mat) :: trw + type(psb_d_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx + type(psb_i_heap) :: heap + + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_sp_invk' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + allocate(uplevs(acsr%get_nzeros()),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + uplevs(:) = 0 + row(:) = dzero + rowlevs(:) = -(n+1) + + call zcsr%allocate(n,n,n*fill_in) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + call psb_ensure_size(n+1, idxs, info) + + + ! + ! + zcsr%irp(1) = 1 + nzz = 0 + + l2 = 0 + outer: do i = 1, n-1 + ! ZW = e_i + call psb_invk_copyin(i,n,acsr,ione,n,row,rowlevs,heap,ktrw,trw,info,& + & sign=-done,inlevs=inlevs) + row(i) = done + rowlevs(i) = 0 + + ! Update loop + call psb_invk_inv(fill_in,i,row,rowlevs,heap,& + & acsr%ja,acsr%irp,acsr%val,uplevs,nidx,idxs,info) + + call psb_invk_copyout(fill_in,i,n,row,rowlevs,nidx,idxs,& + & l2,zcsr%ja,zcsr%irp,zcsr%val,info) + + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = done + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + call zcsr%set_sorted() + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_dsparse_invk + +subroutine psb_d_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,sign,inlevs) + + use psb_base_mod + use psb_d_invk_fact_mod, psb_protect_name => psb_d_invk_copyin + + implicit none + + ! Arguments + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + real(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act, nz + integer(psb_ipk_), parameter :: nrb=16 + real(psb_dpk_) :: sign_ + character(len=20), parameter :: name='invk_copyin' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + if (present(sign)) then + sign_ = sign + else + sign_ = done + end if + + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + if (present(inlevs)) then + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = inlevs(j) + call heap%insert(k,info) + end if + end do + else + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_invk_copyin + + +subroutine psb_d_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + + use psb_base_mod + use psb_d_invk_fact_mod, psb_protect_name => psb_d_invk_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + real(psb_dpk_), allocatable, intent(inout) :: uaspk(:) + real(psb_dpk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: j,isz,err_act,int_err(5),idxp + character(len=20), parameter :: name='psb_diluk_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + do idxp=1,nidx + + j = idxs(idxp) + + if (j>=i) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uaspk) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,uaspk,info) + if (info == psb_success_) call psb_realloc(isz,uia1,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uia1(l2) = j + uaspk(l2) = row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = dzero + rowlevs(j) = -(m+1) + end if + end do + + uia2(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_invk_copyout + +subroutine psb_dinvk_inv(fill_in,i,row,rowlevs,heap,ja,irp,val,uplevs,& + & nidx,idxs,info) + + use psb_base_mod + use psb_d_invk_fact_mod, psb_protect_name => psb_dinvk_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:),uplevs(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + real(psb_dpk_) :: rwk + + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) then +!!$ write(psb_err_unit,*) 'IINVK: ',i,' returning at ',lastk + return + end if + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= dzero).and.(rowlevs(k) <= fill_in)) then + ! + ! Note: since U is scaled while copying it out (see iluk_copyout), + ! we can use rwk in the update below + ! + rwk = row(k) + lrwk = rowlevs(k) + + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Insert the index into the heap for further processing. + ! The fill levels are initialized to a negative value. If we find + ! one, it means that it is an as yet untouched index, so we need + ! to insert it; otherwise it is already on the heap, there is no + ! need to insert it more than once. + ! + if (rowlevs(j)<0) then + call heap%insert(j,info) + if (info /= psb_success_) return + rowlevs(j) = abs(rowlevs(j)) + end if + ! + ! Update row(j) and the corresponding fill level + ! + row(j) = row(j) - rwk * val(jj) + rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1) + end do + + end if + end do + +end subroutine psb_dinvk_inv diff --git a/prec/impl/psb_d_invt_fact.f90 b/prec/impl/psb_d_invt_fact.f90 new file mode 100644 index 00000000..83aa73ff --- /dev/null +++ b/prec/impl/psb_d_invt_fact.f90 @@ -0,0 +1,739 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! + +subroutine psb_d_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_d_invt_bld + use psb_d_ilu_fact_mod + implicit none + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_dpk_), intent(in) :: thresh + real(psb_dpk_), intent(in) :: invthresh + type(psb_dspmat_type), intent(inout) :: lmat, umat + real(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_dspmat_type) :: atmp + real(psb_dpk_), allocatable :: pq(:), pd(:), w(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + real(psb_dpk_) :: sp_thresh + character(len=20) :: name, ch_err, fname + + + info = psb_success_ + name='psb_dinvt_fact' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),w(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + if (info == 0) call psb_ilut_fact(nzrmax,sp_thresh,& + & a,lmat,umat,pd,info,blck=blck,iscale=psb_ilu_scale_maxval_) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (.false.) then +!!$ if (debug_level >= psb_debug_inner_) then + write(fname,'(a,i0,a)') 'invt-lo-',me,'.mtx' + call lmat%print(fname,head="INVTLOW") + write(fname,'(a,i0,a)') 'invt-up-',me,'.mtx' + call umat%print(fname,head="INVTUPP") + end if + + ! + ! Compute the approx U^-1 and L^-1 + ! + nzrmax = invfill + call psb_dsparse_invt(n_row,umat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_dsparse_invt(n_row,lmat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_invt_bld + +subroutine psb_dsparse_invt(n,a,z,nzrmax,sp_thresh,info) + + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_dsparse_invt + + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:),jz(:) + real(psb_dpk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + real(psb_dpk_), allocatable :: row(:) + type(psb_d_coo_sparse_mat) :: trw + type(psb_d_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx, nlw,nup,jmaxup + type(psb_i_heap) :: heap + real(psb_dpk_) :: alpha, nrmi + character(len=20) :: name='psb_sp_invt' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call zcsr%allocate(n,n,n*nzrmax) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + ! + ! + nzz = 0 + row(:) = dzero + rowlevs(:) = 0 + l2 = 0 + zcsr%irp(1) = 1 + + outer: do i = 1, n-1 + ! ZW = e_i + call psb_d_invt_copyin(i,n,acsr,i,ione,n,nlw,nup,jmaxup,nrmi,row,& + & heap,rowlevs,ktrw,trw,info,sign=-done) + if (info /= 0) exit + row(i) = done + ! Adjust norm + if (nrmi < done) then + nrmi = sqrt(done + nrmi**2) + else + nrmi = nrmi*sqrt(done+done/(nrmi**2)) + end if + + call psb_invt_inv(sp_thresh,i,nrmi,row,heap,rowlevs,& + & acsr%ja,acsr%irp,acsr%val,nidx,idxs,info) + if (info /= 0) exit +!!$ write(0,*) 'Calling copyout ',nzrmax,nlw,nup,nidx,l2 + call psb_d_invt_copyout(nzrmax,sp_thresh,i,n,nlw,nup,jmaxup,nrmi,row,& + & nidx,idxs,l2,zcsr%ja,zcsr%irp,zcsr%val,info) + if (info /= 0) exit + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = done + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_dsparse_invt + +subroutine psb_d_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_d_invt_copyin + implicit none + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(inout) :: nrmi + real(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), intent(in), optional :: sign + ! + integer(psb_ipk_) :: k,j,irb,kin,nz, err_act + integer(psb_ipk_), parameter :: nrb=16 + real(psb_dpk_) :: dmaxup, sign_ + real(psb_dpk_), external :: dnrm2 + character(len=20), parameter :: name='invt_copyin' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + sign_ = done + if (present(sign)) sign_ = sign + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = dzero + nrmi = dzero + + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + call heap%insert(k,info) + irwt(k) = 1 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end do + nz = a%irp(i+1) - a%irp(i) + nrmi = dnrm2(nz,a%val(a%irp(i):),ione) + + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_invt_copyin + +subroutine psb_d_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_d_invt_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_dpk_), intent(in) :: thres,nrmi + real(psb_dpk_),allocatable, intent(inout) :: val(:) + real(psb_dpk_), intent(inout) :: row(:) + + ! Local variables + real(psb_dpk_),allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + real(psb_dpk_) :: witem, wmin + integer(psb_ipk_) :: widx + integer(psb_ipk_) :: k,isz,err_act,int_err(5),idxp, nz + type(psb_d_idx_heap) :: heap + character(len=20), parameter :: name='invt_copyout' + character(len=20) :: ch_err + logical :: fndmaxup + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + ! + ! Here we need to apply also the dropping rule base on the fill-in. + ! We do it by putting into a heap the elements that are not dropped + ! by using the 2-norm rule, and then copying them out. + ! + ! The heap goes down on the entry absolute value, so the first item + ! is the largest absolute value. + ! +!!$ write(0,*) 'invt_copyout ',nidx,nup+fill_in + call heap%init(info,dir=psb_asort_down_) + + if (info == psb_success_) allocate(xwid(nidx),xw(nidx),indx(nidx),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/3*nidx/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + ! + ! First the lower part + ! + + nz = 0 + idxp = 0 + + do + + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + if (nz > 1) then + write(psb_err_unit,*) 'Warning: lower triangle from invt???? ' + end if + + + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + idxp = idxp - 1 + nz = 0 + wmin=HUGE(wmin) + if (.false.) then + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if ((widx/=jmaxup).and.(nz > nup+fill_in)) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if (nz > nup+fill_in) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz > nup+fill_in) then + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + end do + end if + end if + + ! + ! Now we put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the upper part of the row + ! + do k=1,nz + l2 = l2 + 1 + if (size(val) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,val,info) + if (info == psb_success_) call psb_realloc(isz,ja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + ja(l2) = xwid(k) + val(l2) = xw(indx(k)) + end do + + ! + ! Set row to zero + ! + do idxp=1,nidx + row(idxs(idxp)) = dzero + end do + + irp(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_d_invt_copyout + +subroutine psb_d_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val,nidx,idxs,info) + + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_d_invt_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_), intent(inout) :: row(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + real(psb_dpk_) :: rwk, alpha + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + irwt(i) = 1 +!!$ write(0,*) 'Drop Threshold ',thres*nrmi + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! Should not happen, but just in case. + ! + if (k == lastk) cycle + lastk = k + + ! + ! Dropping rule based on the threshold: compare the absolute + ! value of each updated entry of row with thres * 2-norm of row. + ! + rwk = row(k) + + if (abs(rwk) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(k) = dzero + irwt(k) = 0 + cycle + else + ! + ! Note: since U is scaled while copying it out (see ilut_copyout), + ! we can use rwk in the update below. + ! + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Update row(j) and, if it is not to be discarded, insert + ! its index into the heap for further processing. + ! + row(j) = row(j) - rwk * val(jj) + if (irwt(j) == 0) then + if (abs(row(j)) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(j) = dzero + else + ! + ! Do the insertion. + ! + call heap%insert(j,info) + if (info /= psb_success_) return + irwt(j) = 1 + end if + end if + end do + end if + + ! + ! If we get here it is an index we need to keep on copyout. + ! + + nidx = nidx + 1 + call psb_ensure_size(nidx,idxs,info,addsz=psb_heap_resize) + if (info /= psb_success_) return + idxs(nidx) = k + irwt(k) = 0 + end do + + irwt(i) = 0 +end subroutine psb_d_invt_inv diff --git a/prec/impl/psb_d_prec_type_impl.f90 b/prec/impl/psb_d_prec_type_impl.f90 index 793afac7..69e48079 100644 --- a/prec/impl/psb_d_prec_type_impl.f90 +++ b/prec/impl/psb_d_prec_type_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,14 +27,14 @@ ! 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. -! -! -! +! +! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -46,7 +46,7 @@ !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific 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 @@ -58,14 +58,14 @@ !!$ 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. -!!$ -!!$ +!!$ +!!$ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine psb_d_apply2_vect(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_d_prec_type, psb_protect_name => psb_d_apply2_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_dprec_type), intent(inout) :: prec type(psb_d_vect_type),intent(inout) :: x @@ -74,9 +74,10 @@ subroutine psb_d_apply2_vect(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans real(psb_dpk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ real(psb_dpk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -84,28 +85,28 @@ subroutine psb_d_apply2_vect(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -114,13 +115,13 @@ subroutine psb_d_apply2_vect(prec,x,y,desc_data,info,trans,work) call prec%prec%apply(done,x,dzero,y,desc_data,info,& & trans=trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -135,7 +136,7 @@ end subroutine psb_d_apply2_vect subroutine psb_d_apply1_vect(prec,x,desc_data,info,trans,work) use psb_base_mod use psb_d_prec_type, psb_protect_name => psb_d_apply1_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_dprec_type), intent(inout) :: prec type(psb_d_vect_type),intent(inout) :: x @@ -144,9 +145,10 @@ subroutine psb_d_apply1_vect(prec,x,desc_data,info,trans,work) real(psb_dpk_),intent(inout), optional, target :: work(:) type(psb_d_vect_type) :: ww - character :: trans_ + character :: trans_ real(psb_dpk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -154,28 +156,28 @@ subroutine psb_d_apply1_vect(prec,x,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -186,13 +188,13 @@ subroutine psb_d_apply1_vect(prec,x,desc_data,info,trans,work) & trans=trans_,work=work_) if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info) call psb_gefree(ww,desc_data,info) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -207,7 +209,7 @@ end subroutine psb_d_apply1_vect subroutine psb_d_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_d_prec_type, psb_protect_name => psb_d_apply2v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_dprec_type), intent(inout) :: prec real(psb_dpk_),intent(inout) :: x(:) @@ -216,9 +218,10 @@ subroutine psb_d_apply2v(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans real(psb_dpk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ real(psb_dpk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -226,40 +229,40 @@ subroutine psb_d_apply2v(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=trans else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if call prec%prec%apply(done,x,dzero,y,desc_data,info,trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -274,7 +277,7 @@ end subroutine psb_d_apply2v subroutine psb_d_apply1v(prec,x,desc_data,info,trans) use psb_base_mod use psb_d_prec_type, psb_protect_name => psb_d_apply1v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_dprec_type), intent(inout) :: prec real(psb_dpk_),intent(inout) :: x(:) @@ -282,43 +285,42 @@ subroutine psb_d_apply1v(prec,x,desc_data,info,trans) character(len=1), optional :: trans character :: trans_ - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act real(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_d_apply1v' info = psb_success_ call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if call prec%prec%apply(done,x,dzero,ww,desc_data,info,& & trans_,work=w1) if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if @@ -332,3 +334,159 @@ subroutine psb_d_apply1v(prec,x,desc_data,info,trans) end subroutine psb_d_apply1v +subroutine psb_dcprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_d_prec_type, psb_protect_name => psb_dcprecseti + implicit none + + class(psb_dprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precseti' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_FILLIN') + call prec%prec%precset(psb_ilu_fill_in_,val,info) + case ('INV_FILLIN') + call prec%prec%precset(psb_inv_fillin_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_dcprecseti + +subroutine psb_dcprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_d_prec_type, psb_protect_name => psb_dcprecsetr + implicit none + + class(psb_dprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetr' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case('SUB_ILUTHRS') + call prec%prec%precset(psb_fact_eps_,val,info) + case('INV_THRESH') + call prec%prec%precset(psb_inv_thresh_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_dcprecsetr + +subroutine psb_dcprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_d_prec_type, psb_protect_name => psb_dcprecsetc + implicit none + + class(psb_dprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetc' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_SOLVE') + ! We select here the type of solver on the block + select case (psb_toupper(trim(string))) + case("ILU") + call prec%prec%precset(psb_f_type_,psb_f_ilu_k_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + case("ILUT") + call prec%prec%precset(psb_f_type_,psb_f_ilu_t_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_t_,info) + case("AINV") + call prec%prec%precset(psb_f_type_,psb_f_ainv_,info) + case("INVK") + call prec%prec%precset(psb_f_type_,psb_f_invk_,info) + case("INVT") + call prec%prec%precset(psb_f_type_,psb_f_invt_,info) + case default + ! Default to ILU(0) factorization + call prec%prec%precset(psb_f_type_,psb_f_ilu_n_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + end select + case ("ILU_ALG") + select case (psb_toupper(trim(string))) + case ("MILU") + call prec%prec%precset(psb_ilu_ialg_,psb_milu_n_,info) + case default + ! Do nothing + end select + case ("ILUT_SCALE") + select case (psb_toupper(trim(string))) + case ("MAXVAL") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_maxval_,info) + case ("DIAG") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_diag_,info) + case ("ARWSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arwsum_,info) + case ("ARCSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arcsum_,info) + case ("ACLSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_aclsum_,info) + case ("NONE") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + case default + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + end select + case ("AINV_ALG") + select case (psb_toupper(trim(string))) + case("LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + case("SYM-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_llk_,info) + case("STAB-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_ft_llk_,info) + case("MLK","LMX") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_mlk_,info) + case default + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + end select + case default + + end select + +end subroutine psb_dcprecsetc diff --git a/prec/impl/psb_d_sp_drop.f90 b/prec/impl/psb_d_sp_drop.f90 new file mode 100644 index 00000000..67c49b6f --- /dev/null +++ b/prec/impl/psb_d_sp_drop.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_d_sp_drop(idiag,nzrmax,sp_thresh,nz,iz,valz,info) + use psb_base_mod + implicit none + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, nzrmax + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: iz(:) + real(psb_dpk_), intent(inout) :: valz(:) + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i, j, idf, nw + real(psb_dpk_) :: witem + integer(psb_ipk_) :: widx + real(psb_dpk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + + if (nz > min(size(iz),size(valz))) then + write(0,*) 'Serious size problem ',nz,size(iz),size(valz) + info = -2 + return + end if + allocate(xw(nz),xwid(nz),indx(nz),stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory allocation failure in sp_drop',nz,info + return + endif + + ! Always keep the diagonal element + idf = -1 + do i=1, nz + if (iz(i) == idiag) then + idf = i + witem = valz(i) + widx = iz(i) + valz(i) = valz(1) + iz(i) = iz(1) + valz(1) = witem + iz(1) = widx + exit + end if + end do + + if (idf == -1) then + + xw(1:nz) = valz(1:nz) + call psb_qsort(xw(1:nz),indx(1:nz),dir=psb_asort_down_) + do i=1, nz + xwid(i) = iz(indx(i)) + end do + nw = min(nz,nzrmax) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + nw = max(nw, 1) + + else + + nw = nz-1 + + xw(1:nw) = valz(2:nz) + + call psb_qsort(xw(1:nw),indx(1:nw),dir=psb_asort_down_) + nw = min(nw,nzrmax-1) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + + do i=1, nw + xwid(i) = iz(1+indx(i)) + end do + nw = nw + 1 + xw(nw) = valz(1) + xwid(nw) = iz(1) + end if + + call psb_msort(xwid(1:nw),indx(1:nw),dir=psb_sort_up_) + + do i=1, nw + valz(i) = xw(indx(i)) + iz(i) = xwid(i) + end do + nz = nw + if (nz>nzrmax) write(0,*) 'in sp_drop: ',nw,nzrmax,nz + deallocate(xw,xwid,indx,stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory deallocation failure in sp_drop',info + return + endif + return +end subroutine psb_d_sp_drop diff --git a/prec/impl/psb_d_sparsify.f90 b/prec/impl/psb_d_sparsify.f90 new file mode 100644 index 00000000..de4628ba --- /dev/null +++ b/prec/impl/psb_d_sparsify.f90 @@ -0,0 +1,260 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_d_sparsify(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,info,istart,iheap,ikr) + use psb_base_mod + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: istart + type(psb_i_heap), optional :: iheap + integer(psb_ipk_), optional :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k + real(psb_dpk_) :: witem + integer(psb_ipk_) :: widx + real(psb_dpk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + type(psb_d_idx_heap) :: heap + + + info = psb_success_ + istart_ = 1 + if (present(istart)) istart_ = max(1,istart) + if (.false.) then + nz = 0 + do i=istart_, n + if ((i == idiag).or.(abs(zw(i)) >= sp_thresh)) then + nz = nz + 1 + iz(nz) = i + valz(nz) = zw(i) + end if + end do + + else + allocate(xw(nzrmax),xwid(nzrmax),indx(nzrmax),stat=info) + if (info /= psb_success_) then + return + end if + + call heap%init(info,dir=psb_asort_down_) + + ! Keep at least the diagonal + nz = 0 + + if (present(iheap)) then + if (.not.(present(ikr))) then + write(psb_err_unit,*) 'Error: if IHEAP then also IKR' + info = -1 + return + end if + last_i = -1 + do + call iheap%get_first(i,iret) + if (iret < 0) exit + ! An index may have been put on the heap more than once. + if (i == last_i) cycle + last_i = i + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + ikr(i) = 0 + end do + + else + + do i=istart_, n + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + end do + end if + + k = 1 + do + if (k == nzrmax) exit + call heap%get_first(witem,widx,info) + if (info == -1) then + info = psb_success_ + exit + endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + k = k + 1 + xw(k) = witem + xwid(k) = widx + end do + call heap%free(info) + nz = k + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + end if + + return + +end subroutine psb_d_sparsify + + +subroutine psb_d_sparsify_list(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,lhead,listv,ikr,info) + use psb_base_mod + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: lhead, listv(:) + integer(psb_ipk_) :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k,current, next + real(psb_dpk_) :: witem + integer(psb_ipk_) :: widx + real(psb_dpk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + istart_ = 1 + allocate(xw(n),xwid(n),indx(n),stat=info) + + current = lhead + lhead = -1 + i = 0 + do while (current >0) + i = i + 1 + xw(i) = zw(current) + xwid(i) = current + + if (current == idiag) then + ! Bring the diagona into first position + witem = xw(1) + widx = xwid(1) + xw(1) = xw(i) + xwid(1) = xwid(i) + xw(i) = witem + xwid(i) = widx + end if + + zw(current) = dzero + ikr(current) = 0 + + next = listv(current) + listv(current) = -1 + current = next + end do + nz = i + if (nz > 2) call psb_hsort(xw(2:nz),ix=xwid(2:nz),& + & dir=psb_asort_down_,flag=psb_sort_keep_idx_) +!!$ write(0,*) 'Done first msort ' +!!$ write(0,*) ' after first msort for idiag ',idiag,' :',nz,sp_thresh +!!$ do i=1, nz +!!$ write(0,*) ' ',xwid(i),xw(i) +!!$ end do + + i = 2 + do while (i<=nz) + if (abs(xw(i)) < sp_thresh) exit + i = i + 1 + end do +!!$ write(0,*) 'NZ ',nz, i, nzrmax + nz = max(1,min(i-1,nzrmax)) + call psb_msort(xwid(1:nz),ix=indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'Done second msort ' + +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,i,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + return + +end subroutine psb_d_sparsify_list diff --git a/prec/impl/psb_dprecbld.f90 b/prec/impl/psb_dprecbld.f90 index dc3d7585..c37a05e9 100644 --- a/prec/impl/psb_dprecbld.f90 +++ b/prec/impl/psb_dprecbld.f90 @@ -44,7 +44,8 @@ subroutine psb_dprecbld(a,desc_a,p,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local scalars - integer(psb_ipk_) :: ictxt, me,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err @@ -58,9 +59,9 @@ subroutine psb_dprecbld(a,desc_a,p,info,amold,vmold,imold) end if info = psb_success_ - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() diff --git a/prec/impl/psb_dprecinit.f90 b/prec/impl/psb_dprecinit.f90 index f28bd446..260a4f51 100644 --- a/prec/impl/psb_dprecinit.f90 +++ b/prec/impl/psb_dprecinit.f90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psb_dprecinit(ictxt,p,ptype,info) +subroutine psb_dprecinit(ctxt,p,ptype,info) use psb_base_mod use psb_d_prec_type, psb_protect_name => psb_dprecinit @@ -37,7 +37,7 @@ subroutine psb_dprecinit(ictxt,p,ptype,info) use psb_d_diagprec, only : psb_d_diag_prec_type use psb_d_bjacprec, only : psb_d_bjac_prec_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_dprec_type), intent(inout) :: p character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -50,7 +50,7 @@ subroutine psb_dprecinit(ictxt,p,ptype,info) if (info /= psb_success_) return end if - p%ictxt = ictxt + p%ctxt = ctxt select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NONE','NOPREC') diff --git a/prec/impl/psb_drwclip.f90 b/prec/impl/psb_drwclip.f90 new file mode 100644 index 00000000..97aea428 --- /dev/null +++ b/prec/impl/psb_drwclip.f90 @@ -0,0 +1,90 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_d_rwclip(nz,ia,ja,val,imin,imax,jmin,jmax) + use psb_base_mod + + implicit none + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: ia(*), ja(*) + real(psb_dpk_), intent(inout) :: val(*) + integer(psb_ipk_), intent(in) :: imin,imax,jmin,jmax + + integer(psb_ipk_) :: i,j + + j = 0 + do i=1, nz + if ((imin <= ia(i)).and.& + & (ia(i) <= imax).and.& + & (jmin <= ja(i)).and.& + & (ja(i) <= jmax) ) then + j = j + 1 + ia(j) = ia(i) + ja(j) = ja(i) + val(j) = val(i) + end if + end do + nz = j +end subroutine psb_d_rwclip diff --git a/prec/impl/psb_dsparse_biconjg_llk.F90 b/prec/impl/psb_dsparse_biconjg_llk.F90 new file mode 100644 index 00000000..919f64ab --- /dev/null +++ b/prec/impl/psb_dsparse_biconjg_llk.F90 @@ -0,0 +1,366 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_dsparse_biconjg_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_d_ainv_tools_mod + use psb_d_biconjg_mod, psb_protect_name => psb_dsparse_biconjg_llk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + real(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + real(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_d_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = dzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = dzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = done + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = dzero + ! !$ end do + zval(i) = done + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then +!!$ write(0,*) i, ' Outer inserting ',ac%ia(j) + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! ! write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha + if (.false..or.(abs(alpha) > sp_thresh)) then +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_dsparse_biconjg_llk_noth + + ! + ! Left-looking variant, with NO drop rule on p(i)/p(j) + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + real(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + real(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_d_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_orth_llk_noth' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = dzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = dzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = done + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = dzero + ! !$ end do + zval(i) = done + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.true.) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.true.) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_dsparse_biconjg_mlk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + real(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:), hlist(:), bfr(:), rwlist(:) + real(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, hlhead, li, mj, kkc, ifrst, ilst, rwhead + type(psb_i_heap) :: heap, rheap + type(psb_d_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_biconjg_mlk' + logical, parameter :: debug=.false., test_merge=.true. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n), & + & hlist(n),rwlist(n),bfr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = dzero + hlist(i) = -1 + rwlist(i) = -1 + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = dzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = done + nzw = 1 + + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = dzero + ! !$ end do + zval(i) = done + izkr(i) = 1 + rwhead = i + + hlhead = -1 + + kkc = 0 + ilst = ac%icp(i)-1 + ifrst = ac%icp(i) + do j = ac%icp(i+1)-1, ac%icp(i), -1 + if (ac%ia(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (.true..or.debug) then +!!$ write(0,*) 'Outer Before insertion : ',hlhead + call printlist(hlhead,hlist) + end if + if (kkc > 0) then +!!$ write(0,*) i,' Outer Inserting : ',kkc,':',ac%ia(ifrst:ilst) + + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + mj = hlhead + if (mj > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outer + + izcr(j) = 0 + if (j>=i) cycle outer + + if (debug) write(0,*) 'update loop, using row: ',j,i,mj + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha +!!$ write(0,*) ' Current list is : ',hlhead +!!$ call printlist(hlhead,hlist) +!!$ + + + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=z%icp(j) + ilst=z%icp(j+1)-1 + call hlmerge(rwhead,rwlist,z%ia(ifrst:ilst)) +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr +!!$ call hlmerge(rwhead,rwlist,(/kr/)) + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',ac%ia(ifrst:ilst) + end if + if (ilst >= ifrst) then +!!$ write(0,*) j,i,' Inner inserting ',ac%ia(ifrst:ilst) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outer + call a%csget(i,i,nzra,ia,ja,val,info) + call rwclip(nzra,ia,ja,val,ione,n,ione,n) + p(i) = psb_spge_dot(nzra,ja,val,zval) + if (abs(p(i)) < d_epstol) & + & p(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzz+nzrz, z%ia, info) + call psb_ensure_size(nzz+nzrz, z%val, info) + ipz1 = z%icp(i) + do j=1, nzrz + z%ia(ipz1 + j -1) = ia(j) + z%val(ipz1 + j -1) = val(j) + end do + z%icp(i+1) = ipz1 + nzrz + nzz = nzz + nzrz + + + ! WVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = dzero + ! !$ end do + zval(i) = done + izkr(i) = 1 + rwhead = i + hlhead = -1 + + kkc = 0 + ilst = a%irp(i)-1 + ifrst = a%irp(i) + do j = a%irp(i+1)-1, a%irp(i), -1 + if (a%ja(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (debug) then + write(0,*) 'Outer Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Outer Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + if (kkc > 0 ) then + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outerw: do + mj = hlhead + if (hlhead > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outerw + + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=w%icp(j) + ilst=w%icp(j+1)-1 + call hlmerge(rwhead,rwlist,w%ia(ifrst:ilst)) + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + if (debug) write(0,*) 'update loop, adding indices: ',& + & a%ja(a%irp(kr):a%irp(kr+1)-1) + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outerw + ip1 = ac%icp(i) + ip2 = ac%icp(i+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + if (abs(q(i)) < d_epstol) & + & q(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzw+nzrz, w%ia, info) + call psb_ensure_size(nzw+nzrz, w%val, info) + ipz1 = w%icp(i) + do j=1, nzrz + w%ia(ipz1 + j -1) = ia(j) + w%val(ipz1 + j -1) = val(j) + end do + w%icp(i+1) = ipz1 + nzrz + nzw = nzw + nzrz + + end do + +contains + + subroutine hlmerge(head,listv,vals) + integer(psb_ipk_), intent(inout) :: head, listv(:) + integer(psb_ipk_), intent(in) :: vals(:) + integer(psb_ipk_) :: i,j,k, lh, lv, nv, vv, flh, ph + + nv = size(vals) + lh = head + flh = -1 + lv = 1 + if ((head < 0).and.(nv > 0)) then + ! Adjust head if empty + head = vals(lv) + lv = lv + 1 + else if ((head > 0) .and. (nv >0)) then + ! Adjust head if first item less than it + if (head > vals(lv)) then + listv(vals(lv)) = head + head = vals(lv) + lv = lv + 1 + end if + end if + + lh = head + ph = lh + do while ((lh > 0) .and. (lv <= nv)) + if (lh == vals(lv)) then + lv = lv + 1 + else if (lh > vals(lv)) then + listv(vals(lv)) = lh + listv(ph) = vals(lv) + lh = vals(lv) + lv = lv + 1 + else + ph = lh + lh = listv(lh) + end if + end do + lh = ph + do while (lv <= nv) + listv(lh) = vals(lv) + lh = listv(lh) + lv = lv + 1 + end do + end subroutine hlmerge + + + subroutine printlist(head,listv) + integer(psb_ipk_), intent(in) :: head, listv(:) + integer(psb_ipk_) :: li + + li = head + do while (li > 0) + write(0,*) 'Item: ', li + li = listv(li) + end do + end subroutine printlist + +end subroutine psb_dsparse_biconjg_mlk diff --git a/prec/impl/psb_dsparse_biconjg_s_ft_llk.F90 b/prec/impl/psb_dsparse_biconjg_s_ft_llk.F90 new file mode 100644 index 00000000..fbf4bc02 --- /dev/null +++ b/prec/impl/psb_dsparse_biconjg_s_ft_llk.F90 @@ -0,0 +1,414 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_dsparse_biconjg_s_ft_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_d_ainv_tools_mod + use psb_d_biconjg_mod, psb_protect_name => psb_dsparse_biconjg_s_ft_llk + + ! + ! Left-looking variant, stabilized i.e. product by A is applied + ! to compute the diagonal elements. + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + real(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:),iww(:) + real(psb_dpk_), allocatable :: zval(:),val(:), q(:), ww(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj, nzww,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, nzrw + type(psb_i_heap) :: heap, rheap + type(psb_d_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha, tmpq,tmpq2 + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),iww(n),ww(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! Init pointers to: + ! ljr(i): last occupied column index within row I + ! izcr(i): first occupied row index within column I + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = dzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = dzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = done + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = dzero + ! !$ end do + zval(i) = done + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) lastj) then + lastj = j + exit inner + end if + end do inner + izcr(j) = 0 + if (j>=i) exit outer + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = w%icp(j) + ip2 = w%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_d_spvspm(done,a,nzra,w%ia(ip1:ip2),w%val(ip1:ip2),& + & dzero,nzww,iww,ww,info) + + p(i) = psb_spge_dot(nzww,iww,ww,zval) + + ipz1 = z%icp(j) + ipz2 = z%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-p(i)/p(j)) +!!$ write(0,*) ' p(i)/p(j) ',i,j,alpha,p(i),p(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) exit outerw + if (debug) write(0,*) 'update loop, using row: ',j + if (.false.) then + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + else + ip1 = z%icp(j) + ip2 = z%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_d_spmspv(done,ac,nzra,z%ia(ip1:ip2),z%val(ip1:ip2),& + & dzero,nzww,iww,ww,info) + + q(i) = psb_spge_dot(nzww,iww,ww,zval) + end if + + ipz1 = w%icp(j) + ipz2 = w%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-q(i)/q(j)) +!!$ write(0,*) ' q(i)/q(j) ',i,j,alpha,q(i),q(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_dsparse_biconjg_s_llk + + ! + ! Left-looking variant SYMMETRIC/HERMITIAN A. You have been warned! + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + real(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + real(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw,kk + type(psb_i_heap) :: heap, rheap + type(psb_d_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha, zvalmax + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = dzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = dzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + zvalmax = done + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = dzero + ! !$ end do + zval(i) = done + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.false..or.(abs(alpha) > sp_thresh)) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) +!!$ if (abs(zval(kr)) > 1e16) then +!!$ write(0,*) i,j,p(i),p(j),alpha,z%val(k),alpha*z%val(k),kr,zval(kr) +!!$ end if + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + iscale_ = psb_ilu_scale_none_ + if (present(iscale)) iscale_ = iscale + weight = sone + ! + ! Check the memory available to hold the W and Z factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = desc%get_local_rows() + allocate(pq(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + ! + ! Ok, let's start first with Z (i.e. Upper) + ! + call a%csclip(acoo,info,imax=n_row,jmax=n_row) + call acsr%mv_from_coo(acoo,info) + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + + case(psb_ilu_scale_maxval_) + weight = acsr%maxval() + weight = sone/weight + call acsr%scal(weight,info) + + case(psb_ilu_scale_arcsum_) + allocate(arws(n_row),acls(n_row),ad(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + call acsr%arwsum(arws) + call acsr%aclsum(acls) + ad(1:n_row) = sqrt(sqrt(arws(1:n_row)*acls(1:n_row))) + ad(1:n_row) = sone/ad(1:n_row) + call acsr%scal(ad,info,side='L') + call acsr%scal(ad,info,side='R') + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + ! + ! Here for the actual workhorses. + ! Only biconjg is surviving for now.... + ! + call psb_sparse_biconjg(alg,n_row,acsr,pq,& + & zmat,wmat,nzrmax,sp_thresh,info) + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparse_biconjg') + goto 9999 + end if + call atmp%mv_from(acsr) + + ! + ! Is this right??? + ! + do i=1, n_row + if (abs(pq(i)) < d_epstol) then + pq(i) = sone + else + pq(i) = sone/pq(i) + end if + end do + + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + case(psb_ilu_scale_maxval_) + pq(:) = pq(:)*weight + + case(psb_ilu_scale_arcsum_) + call zmat%scal(ad,info,side='L') + call wmat%scal(ad,info,side='R') + + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + call psb_move_alloc(pq,d,info) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_ainv_bld diff --git a/prec/impl/psb_s_bjacprec_impl.f90 b/prec/impl/psb_s_bjacprec_impl.f90 index 3a9cfce2..ce1f7444 100644 --- a/prec/impl/psb_s_bjacprec_impl.f90 +++ b/prec/impl/psb_s_bjacprec_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,28 +27,29 @@ ! 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. -! -! +! +! subroutine psb_s_bjac_dump(prec,info,prefix,head) use psb_base_mod use psb_s_bjacprec, psb_protect_name => psb_s_bjac_dump - implicit none + implicit none class(psb_s_bjac_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than - ! len of prefix_ + ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) - if (present(prefix)) then + if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) else prefix_ = "dump_fact_s" @@ -73,7 +74,7 @@ end subroutine psb_s_bjac_dump subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_s_bjacprec, psb_protect_name => psb_s_bjac_apply_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_s_bjac_prec_type), intent(inout) :: prec real(psb_spk_),intent(in) :: alpha,beta @@ -87,7 +88,8 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) integer(psb_ipk_) :: n_row,n_col real(psb_spk_), pointer :: ww(:), aux(:) type(psb_s_vect_type) :: wv, wv1 - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit logical :: do_alloc_wrk @@ -99,8 +101,8 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -116,12 +118,12 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (x%get_nrows() < n_row) then + if (x%get_nrows() < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (y%get_nrows() < n_row) then + if (y%get_nrows() < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -138,9 +140,9 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) @@ -150,19 +152,19 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) allocate(ww(n_col),aux(4*n_col),stat=info) endif - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if do_alloc_wrk = .not.prec%is_allocated_wrk() if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate (wv => prec%wrk(1), wv1 => prec%wrk(2)) - + select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) + select case(trans_) case('N') call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,wv,desc_data,info,& @@ -170,31 +172,58 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + case('T') call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,& & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + case('C') - + call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,wv,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + call wv1%mlt(sone,prec%dv,wv,szero,info,conjgx=trans_) - + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv1,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + case('N') + call psb_spmm(sone,prec%av(psb_l_pr_),x,szero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + if (info == psb_success_) call wv1%mlt(sone,prec%dv,wv,szero,info) + if(info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1,& + & beta,y,desc_data,info, trans=trans_, work=aux,doswap=.false.) + + case('T','C') + call psb_spmm(sone,prec%av(psb_l_pr_),x,szero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + if (info == psb_success_) call wv1%mlt(sone,prec%dv,wv,szero,info) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1, & + & beta,y,desc_data,info,trans=trans_,work=aux,doswap=.false.) + end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if - + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') @@ -202,12 +231,12 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end select end associate - + call psb_halo(y,desc_data,info,data=psb_comm_mov_) if (do_alloc_wrk) call prec%free_wrk(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -229,7 +258,7 @@ end subroutine psb_s_bjac_apply_vect subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_s_bjacprec, psb_protect_name => psb_s_bjac_apply - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_s_bjac_prec_type), intent(inout) :: prec real(psb_spk_),intent(in) :: alpha,beta @@ -242,7 +271,9 @@ subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) ! Local variables integer(psb_ipk_) :: n_row,n_col real(psb_spk_), pointer :: ww(:), aux(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_d_vect_type) :: tx,ty + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit character :: trans_ @@ -253,8 +284,8 @@ subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -270,12 +301,12 @@ subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (size(x) < n_row) then + if (size(x) < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(y) < n_row) then + if (size(y) < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -292,29 +323,29 @@ subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) select case(trans_) case('N') @@ -341,11 +372,42 @@ subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) & trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + + case('N') + call psb_spmm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('T') + call psb_spmm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('C') + call psb_spmm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * (prec%dv%v%v(1:n_row)) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + end select + case default info = psb_err_internal_error_ @@ -355,8 +417,8 @@ subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_halo(y,desc_data,info,data=psb_comm_mov_) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -394,11 +456,26 @@ subroutine psb_s_bjac_precinit(prec,info) call psb_Errpush(info,name) goto 9999 end if + call psb_realloc(psb_rfpsz,prec%rprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if prec%iprcparm(:) = 0 prec%iprcparm(psb_p_type_) = psb_bjac_ prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ prec%iprcparm(psb_ilu_fill_in_) = 0 + prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_ + prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_ + prec%iprcparm(psb_inv_fillin_) = 0 + prec%iprcparm(psb_ainv_alg_) = psb_ainv_llk_ + + + prec%rprcparm(:) = 0 + prec%rprcparm(psb_fact_eps_) = 1E-1_psb_spk_ + prec%rprcparm(psb_inv_thresh_) = 1E-1_psb_spk_ call psb_erractionrestore(err_act) @@ -413,7 +490,8 @@ end subroutine psb_s_bjac_precinit subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct + use psb_s_ilu_fact_mod + use psb_s_ainv_fact_mod use psb_s_bjacprec, psb_protect_name => psb_s_bjac_precbld Implicit None @@ -425,14 +503,16 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) class(psb_s_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold - ! .. Local Scalars .. - integer(psb_ipk_) :: i, m + ! .. Local Scalars .. + integer(psb_ipk_) :: i, m, ialg, fill_in, iscale, inv_fill, iinvalg integer(psb_ipk_) :: ierr(5) character :: trans, unitd - type(psb_s_csr_sparse_mat), allocatable :: lf, uf + type(psb_sspmat_type), allocatable :: lf, uf real(psb_spk_), allocatable :: dd(:) + real(psb_spk_) :: fact_eps, inv_thresh integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me character(len=20) :: name='s_bjac_precbld' character(len=20) :: ch_err @@ -444,9 +524,9 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_ctxt() - call prec%set_ctxt(ictxt) - call psb_info(ictxt, me, np) + ctxt=desc_a%get_ctxt() + call prec%set_ctxt(ctxt) + call psb_info(ctxt, me, np) m = a%get_nrows() if (m < 0) then @@ -458,19 +538,100 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) trans = 'N' unitd = 'U' + ! We check if all the information contained in the preconditioner structure + ! are meaningful, otherwise we give an error and get out of the build + ! procedure + ialg = prec%iprcparm(psb_ilu_ialg_) ! Integer for ILU type algorithm + iinvalg = prec%iprcparm(psb_ainv_alg_) ! Integer for AINV type algorithm + iscale = prec%iprcparm(psb_ilu_scale_) ! Integer for scaling of matrix + fact_eps = prec%rprcparm(psb_fact_eps_) ! Drop-tolerance for factorization + inv_thresh = prec%rprcparm(psb_inv_thresh_) ! Drop-tolerance for inverse + fill_in = prec%iprcparm(psb_ilu_fill_in_) ! Fill-In for factorization + inv_fill = prec%iprcparm(psb_inv_fillin_) ! Fill-In for inverse factorization + + ! Check if the type of scaling is known, pay attention that not all the + ! scalings make sense for all the factorization, if something that does not + ! make sense is required the factorization routine will fail in an + ! unnrecoverable way. + if ((iscale == psb_ilu_scale_none_).or.& + (iscale == psb_ilu_scale_maxval_).or.& + (iscale == psb_ilu_scale_diag_).or.& + (iscale == psb_ilu_scale_arwsum_).or.& + (iscale == psb_ilu_scale_aclsum_).or.& + (iscale == psb_ilu_scale_arcsum_)) then + ! Do nothing: admissible request + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_scale_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the variant for the AINV is known to the library + if( (prec%iprcparm(psb_f_type_) == psb_f_ainv_).and.(& + & (iinvalg == psb_ainv_llk_).or.(iinvalg == psb_ainv_s_llk_).or. & + & (iinvalg == psb_ainv_s_ft_llk_).or.(iinvalg == psb_ainv_llk_noth_).or.& + & (iinvalg == psb_ainv_mlk_).or.(iinvalg == psb_ainv_lmx_ ) ) ) then + ! Do nothing, these are okay + else + info=psb_err_from_subroutine_ + ch_err='psb_ainv_alg_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the drop-tolerance make sense, if fact_eps > 1 and we are requiring + ! either ILUT, or INVT we give an error. + if( (fact_eps > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ilu_t_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_fact_eps_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! It the drop-tolerance for the inverse factors, inv_thresh > 1 and we are + ! requiring AINV or, or INVT we give an error + if( (inv_thresh > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ainv_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_inv_thresh_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Checks relative to the fill-in parameters + if (prec%iprcparm(psb_f_type_) == psb_f_ilu_n_) then + if(fill_in < 0) then + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fill_in_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + else if (fill_in == 0) then + ! If the requested level of fill is equal to zero, we default to the + ! specialized ILU(0) routine + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + end if + end if + ! If no limit on the fill_in is required we allow every fill, this is needed + ! since this quantity is used to allocate the auxiliary vectors for the + ! factorization + if (inv_fill <= 0) inv_fill = m + + ! Select on the type of factorization to be used select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_) + ! ILU(0) Factorization: the total number of nonzeros of the factorized matrix + ! is equal to the one of the input matrix - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) call prec%av(i)%free() enddo deallocate(prec%av,stat=info) endif end if - if (.not.allocated(prec%av)) then + if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -497,27 +658,27 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) end if allocate(dd(n_row),stat=info) - if (info == psb_success_) then + if (info == psb_success_) then allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) end if end if end if - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) + ! This is where we have no renumbering, thus no need + call psb_ilu0_fact(ialg,a,lf,uf,dd,info) if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) call prec%av(psb_l_pr_)%set_asb() call prec%av(psb_u_pr_)%set_asb() call prec%av(psb_l_pr_)%trim() @@ -526,12 +687,375 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) ! call move_alloc(dd,prec%d) else info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' + ch_err='psb_ilu0_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(psb_f_none_) + case(psb_f_ilu_k_) + ! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on + ! the type of the variant of the algorithm the may be forgotten or added to + ! the diagonal (MILU) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ilu_t_) + ! ILU(N,E) Incomplete LU factorization with thresholding and level of fill + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ainv_) + ! Approximate Inverse Factorizations based on variants of the incomplete + ! biconjugation algorithms + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_ainv_fact(a,iinvalg,inv_fill,inv_thresh,lf,dd,uf,desc_a,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invk_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(n) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invk_fact(a,fill_in, inv_fill,lf,dd,uf,desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invt_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(eps) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_s_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invt_fact(a,fill_in,inv_fill,fact_eps,inv_thresh,lf,dd,uf,& + & desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) @@ -544,7 +1068,7 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) goto 9999 end select - if (present(amold)) then + if (present(amold)) then call prec%av(psb_l_pr_)%cscnv(info,mold=amold) call prec%av(psb_u_pr_)%cscnv(info,mold=amold) end if @@ -563,8 +1087,8 @@ subroutine psb_s_bjac_precseti(prec,what,val,info) Implicit None class(psb_s_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='s_bjac_precset' @@ -572,34 +1096,33 @@ subroutine psb_s_bjac_precseti(prec,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(prec%iprcparm)) then + if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_f_type_) prec%iprcparm(psb_f_type_) = val - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_ilu_fill_in_) prec%iprcparm(psb_ilu_fill_in_) = val + case (psb_ilu_ialg_) + prec%iprcparm(psb_ilu_ialg_) = val + + case (psb_ilu_scale_) + prec%iprcparm(psb_ilu_scale_) = val + + case (psb_ainv_alg_) + prec%iprcparm(psb_ainv_alg_) = val + + case(psb_inv_fillin_) + prec%iprcparm(psb_inv_fillin_) = val + case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what end select @@ -609,3 +1132,45 @@ subroutine psb_s_bjac_precseti(prec,what,val,info) 9999 call psb_error_handler(err_act) return end subroutine psb_s_bjac_precseti + +subroutine psb_s_bjac_precsetr(prec,what,val,info) + + use psb_base_mod + use psb_s_bjacprec, psb_protect_name => psb_s_bjac_precsetr + Implicit None + + class(psb_s_bjac_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, nrow + character(len=20) :: name='s_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%rprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + + case (psb_fact_eps_) + prec%rprcparm(psb_fact_eps_) = val + + case (psb_inv_thresh_) + prec%rprcparm(psb_inv_thresh_) = val + + case default + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_bjac_precsetr diff --git a/prec/impl/psb_s_diagprec_impl.f90 b/prec/impl/psb_s_diagprec_impl.f90 index 79ba27cc..29e2e1a7 100644 --- a/prec/impl/psb_s_diagprec_impl.f90 +++ b/prec/impl/psb_s_diagprec_impl.f90 @@ -38,15 +38,16 @@ subroutine psb_s_diag_dump(prec,info,prefix,head) integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/impl/psb_s_ilu0_fact.f90 b/prec/impl/psb_s_ilu0_fact.f90 index bc2dd5ab..b6f442e9 100644 --- a/prec/impl/psb_s_ilu0_fact.f90 +++ b/prec/impl/psb_s_ilu0_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_silu0_fact.f90 ! ! Subroutine: psb_silu0_fact @@ -75,7 +75,7 @@ ! ! This routine computes either the ILU(0) or the MILU(0) factorization of ! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a given level of a ! multilevel preconditioner. ! @@ -83,10 +83,10 @@ ! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, ! SIAM, 2003, Chapter 10. ! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is CSR. +! The diagonal of the U factor is stored separately (actually, the inverse of the +! diagonal entries is stored; this is then managed in the solve stage associated ! to the ILU(0)/MILU(0) factorization). ! ! The routine copies and factors "on the fly" from a and blck into l (L factor), @@ -94,7 +94,7 @@ ! ! This implementation of ILU(0)/MILU(0) is faster than the implementation in ! psb_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! +! ! ! Arguments: ! ialg - integer, input. @@ -121,7 +121,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_sspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -129,7 +129,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. -! +! subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) use psb_base_mod @@ -157,30 +157,30 @@ subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(upd)) then - upd_ = psb_toupper(upd) + if (present(upd)) then + upd_ = psb_toupper(upd) else upd_ = 'F' end if - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -212,12 +212,12 @@ subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() if(info.ne.0) then @@ -226,7 +226,7 @@ subroutine psb_silu0_fact(ialg,a,l,u,d,info,blck, upd) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - deallocate(blck_) + deallocate(blck_) endif call psb_erractionrestore(err_act) @@ -243,9 +243,9 @@ contains ! Version: real ! Note: internal subroutine of psb_silu0_fact. ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' ! (block-Jacobi preconditioner/solver, Additive Schwarz ! preconditioner) corresponding to a given level of a multilevel preconditioner. ! @@ -257,7 +257,7 @@ contains ! ! The routine copies and factors "on the fly" from the sparse matrix structures a ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! + ! ! ! Arguments: ! ialg - integer, input. @@ -296,7 +296,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - real(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -305,18 +305,18 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output. ! The number of nonzero entries in lval. ! l2 - integer, output. ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_silu0_factint(ialg,a,b,& & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: ialg @@ -332,7 +332,7 @@ contains real(psb_spk_) :: dia,temp integer(psb_ipk_), parameter :: nrb=16 type(psb_s_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: int_err(5) character(len=20) :: name, ch_err name='psb_silu0_factint' @@ -346,10 +346,10 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione,ialg,izero,izero,izero/)) goto 9999 end select @@ -363,7 +363,7 @@ contains end if m = ma+mb - if (psb_toupper(upd) == 'F' ) then + if (psb_toupper(upd) == 'F' ) then lirp(1) = 1 uirp(1) = 1 l1 = 0 @@ -379,14 +379,14 @@ contains if (i <= ma) then ! ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval + ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) else ! ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval + ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) @@ -437,7 +437,7 @@ contains ! dia = dia - temp*uval(jj) cycle updateloop - ! + ! else if (j > i) then ! ! search u(i,*) (i-th row of U) for a matching index j @@ -454,23 +454,23 @@ contains end if enddo end if - ! - ! If we get here we missed the cycle updateloop, which means + ! + ! If we get here we missed the cycle updateloop, which means ! that this entry does not match; thus we accumulate on the ! diagonal for MILU(0). ! - if (ialg == psb_milu_n_) then + if (ialg == psb_milu_n_) then dia = dia - temp*uval(jj) end if enddo updateloop enddo - ! + ! ! Check the pivot size - ! + ! if (abs(dia) < s_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') abs(dia) @@ -493,7 +493,7 @@ contains else write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 @@ -515,7 +515,7 @@ contains ! Version: real ! Note: internal subroutine of psb_silu0_fact ! - ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type + ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type ! data structure a, into the arrays lval and uval and into the scalar variable ! dia, corresponding to the lower and upper triangles of A and to the diagonal ! entry of the row, respectively. The entries in lval and uval are stored @@ -529,14 +529,14 @@ contains ! ! The routine is used by psb_silu0_factint in the computation of the ILU(0)/MILU(0) ! factorization of a local sparse matrix. - ! + ! ! TODO: modify the routine to allow copying into output L and U that are ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! then use the ILU(0) internal for subsequent calls with the same pattern. ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -570,13 +570,13 @@ contains ! to the CSR storage format. ! uval - real(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the - ! upper triangle are copied. + ! upper triangle are copied. ! ktrw - integer, input/output. ! The index identifying the last entry taken from the ! staging buffer trw. See below. ! trw - type(psb_sspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -608,10 +608,10 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - if (psb_toupper(upd) == 'F') then + if (psb_toupper(upd) == 'F') then - select type(aa => a%a) - type is (psb_s_csr_sparse_mat) + select type(aa => a%a) + type is (psb_s_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format @@ -633,19 +633,19 @@ contains end if enddo - class default + class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into lval, dia, uval, through ! successive calls to ilu_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) + call aa%csget(i,i+irb-1,trw,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='csget' @@ -656,7 +656,7 @@ contains end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) @@ -680,7 +680,7 @@ contains write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 diff --git a/prec/impl/psb_s_iluk_fact.f90 b/prec/impl/psb_s_iluk_fact.f90 index 4b9f1f3f..6129663b 100644 --- a/prec/impl/psb_s_iluk_fact.f90 +++ b/prec/impl/psb_s_iluk_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_siluk_fact.f90 ! ! Subroutine: psb_siluk_fact @@ -74,7 +74,7 @@ ! Contains: psb_siluk_factint, iluk_copyin, iluk_fact, iluk_copyout. ! ! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to +! diagonal blocks of a distributed matrix. These factorizations are used to ! build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a certain level of a ! multilevel preconditioner. @@ -88,7 +88,7 @@ ! U factors is CSR. The diagonal of the U factor is stored separately (actually, ! the inverse of the diagonal entries is stored; this is then managed in the solve ! stage associated to the ILU(k)/MILU(k) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -118,7 +118,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_sspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -126,7 +126,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_base_mod @@ -143,7 +143,7 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) real(psb_spk_), intent(inout) :: d(:) ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act - + type(psb_sspmat_type), pointer :: blck_ type(psb_s_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -152,17 +152,17 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -170,7 +170,7 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -203,15 +203,15 @@ subroutine psb_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -280,7 +280,7 @@ contains ! according to the CSR storage format. ! lia2 - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. + ! of the L factor in laspk, according to the CSR storage format. ! uval - real(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -289,12 +289,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in laspk. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_siluk_factint(fill_in,ialg,a,b,& @@ -304,7 +304,7 @@ contains implicit none - ! Arguments + ! Arguments integer(psb_ipk_), intent(in) :: fill_in, ialg type(psb_sspmat_type),intent(in) :: a,b integer(psb_ipk_),intent(inout) :: l1,l2,info @@ -330,14 +330,14 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,& & i_err=(/itwo,ialg,izero,izero,izero/)) goto 9999 end select - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) @@ -349,7 +349,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the iluk_copyin function + ! Allocate a temporary buffer for the iluk_copyin function ! call trw%allocate(izero,izero,ione) @@ -361,7 +361,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -381,34 +381,34 @@ contains uplevs(:) = m+1 row(:) = szero rowlevs(:) = -(m+1) - + ! ! Cycle over the matrix rows ! do i = 1, m - + ! ! At each iteration of the loop we keep in a heap the column indices ! affected by the factorization. The heap is initialized and filled ! in the iluk_copyin routine, and updated during the elimination, in ! the iluk_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = szero if (i<=ma) then ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) else ! ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! + ! (as (i-ma)-th row) + ! call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) endif - + ! Do an elimination step on the current row. It turns out we only ! need to keep track of fill levels for the upper triangle, hence we ! do not have a lowlevs variable. @@ -417,7 +417,7 @@ contains & d,uja,uirp,uval,uplevs,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) if (info /= psb_success_) then @@ -474,11 +474,11 @@ contains ! ! This routine is used by psb_siluk_factint in the computation of the ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -510,7 +510,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_sspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -521,8 +521,8 @@ contains use psb_base_mod implicit none - - ! Arguments + + ! Arguments type(psb_sspmat_type), intent(in) :: a type(psb_s_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i,m,jmin,jmax @@ -542,17 +542,17 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - call heap%init(info) + call heap%init(info) - select type (aa=> a%a) - type is (psb_s_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_s_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! - + do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) rowlevs(k) = 0 call heap%insert(k,info) @@ -562,14 +562,14 @@ contains class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to iluk_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -581,11 +581,11 @@ contains ktrw=1 end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) rowlevs(k) = 0 call heap%insert(k,info) @@ -674,10 +674,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i, fill_in integer(psb_ipk_), intent(inout) :: nidx,info integer(psb_ipk_), intent(inout) :: rowlevs(:) @@ -690,7 +690,7 @@ contains real(psb_spk_) :: rwk info = psb_success_ - if (.not.allocated(idxs)) then + if (.not.allocated(idxs)) then allocate(idxs(200),stat=info) if (info /= psb_success_) return endif @@ -702,34 +702,34 @@ contains ! do ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) return - ! + ! ! Just in case an index has been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k nidx = nidx + 1 - if (nidx>size(idxs)) then + if (nidx>size(idxs)) then call psb_realloc(nidx+psb_heap_resize,idxs,info) if (info /= psb_success_) return end if idxs(nidx) = k - - if ((row(k) /= szero).and.(rowlevs(k) <= fill_in).and.(ki) then + else if (j>i) then ! ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! ! Figure out a good reallocation size! ! isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -941,11 +941,11 @@ contains end if uja(l2) = j uval(l2) = row(j) - uplevs(l2) = rowlevs(j) + uplevs(l2) = rowlevs(j) else if (ialg == psb_milu_n_) then ! ! MILU(k): add discarded entries to the diagonal one - ! + ! d(i) = d(i) + row(j) end if ! @@ -963,13 +963,13 @@ contains lirp(i+1) = l1 + 1 uirp(i+1) = l2 + 1 - ! + ! ! Check the pivot size ! if (abs(d(i)) < s_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) diff --git a/prec/impl/psb_s_ilut_fact.f90 b/prec/impl/psb_s_ilut_fact.f90 index 33b4374c..43cacf41 100644 --- a/prec/impl/psb_s_ilut_fact.f90 +++ b/prec/impl/psb_s_ilut_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_silut_fact.f90 ! ! Subroutine: psb_silut_fact @@ -87,7 +87,7 @@ ! CSR. The diagonal of the U factor is stored separately (actually, the ! inverse of the diagonal entries is stored; this is then managed in the ! solve stage associated to the ILU(k,t) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -114,7 +114,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_sspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -122,9 +122,9 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - + use psb_base_mod use psb_s_ilu_fact_mod, psb_protect_name => psb_silut_fact @@ -141,7 +141,7 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) integer(psb_ipk_), intent(in), optional :: iscale ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - + type(psb_sspmat_type), pointer :: blck_ type(psb_s_csr_sparse_mat) :: ll, uu real(psb_spk_) :: scale @@ -151,34 +151,34 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) info = psb_success_ call psb_erractionsave(err_act) - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) goto 9999 end if - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(iscale)) then + if (present(iscale)) then iscale_ = iscale else iscale_ = psb_ilu_scale_none_ end if - - select case(iscale_) + + select case(iscale_) case(psb_ilu_scale_none_) scale = sone case(psb_ilu_scale_maxval_) @@ -189,10 +189,10 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) goto 9999 end select - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -225,15 +225,15 @@ subroutine psb_silut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -298,7 +298,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - real(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -307,12 +307,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in lval. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_silut_factint(fill_in,thres,a,b,& @@ -320,7 +320,7 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: fill_in @@ -355,7 +355,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the ilut_copyin function + ! Allocate a temporary buffer for the ilut_copyin function ! call trw%allocate(izero,izero,ione) if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) @@ -366,7 +366,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -396,10 +396,10 @@ contains ! in the ilut_copyin function, and updated during the elimination, in ! the ilut_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = czero - if (i<=ma) then + if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& & row,heap,ktrw,trw,info) else @@ -414,7 +414,7 @@ contains & d,uja,uirp,uval,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) @@ -429,7 +429,7 @@ contains ! ! Adjust diagonal accounting for scale factor ! - if (weight /= sone) then + if (weight /= sone) then d(1:m) = d(1:m)*weight end if @@ -469,7 +469,7 @@ contains ! - storing into a heap the column indices of the nonzero entries of the copied ! row; ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; + ! in the part of the row belonging to the upper triangle; ! - computing the 2-norm of the row. ! The output array row is such that it contains a full row of A, i.e. it contains ! also the zero entries of the row. This is useful for the elimination step @@ -482,11 +482,11 @@ contains ! ! This routine is used by psb_silut_factint in the computation of the ILU(k,t) ! factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -533,7 +533,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_sspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -542,7 +542,7 @@ contains subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& & nrmi,weight,row,heap,ktrw,trw,info) use psb_base_mod - implicit none + implicit none type(psb_sspmat_type), intent(in) :: a type(psb_s_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd @@ -584,29 +584,29 @@ contains dmaxup = szero nrmi = szero - select type (aa=> a%a) - type is (psb_s_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_s_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if end if end if end do - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 @@ -617,16 +617,16 @@ contains class default - + ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to ilut_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -639,18 +639,18 @@ contains kin = ktrw nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if @@ -734,10 +734,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i integer(psb_ipk_), intent(inout) :: nidx,info real(psb_spk_), intent(in) :: thres,nrmi @@ -753,23 +753,23 @@ contains call psb_ensure_size(200*ione,idxs,info) if (info /= psb_success_) return nidx = 0 - lastk = -1 + lastk = -1 ! ! Do while there are indices to be processed ! do - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) exit - ! + ! ! An index may have been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k lowert: if (k nidx) exit if (idxs(idxp) >= i) exit @@ -987,8 +987,8 @@ contains ! if (abs(witem) < thres*nrmi) cycle - nz = nz + 1 - xw(nz) = witem + nz = nz + 1 + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1000,9 +1000,9 @@ contains ! ! Now we have to take out the first nlw+fill_in entries - ! + ! if (nz <= nlw+fill_in) then - ! + ! ! Just copy everything from xw, and it is already ordered ! else @@ -1014,7 +1014,7 @@ contains call psb_errpush(info,name,a_err='psb_heap_get_first') goto 9999 end if - + xw(k) = witem xwid(k) = widx end do @@ -1029,15 +1029,15 @@ contains ! Copy out the lower part of the row ! do k=1,nz - l1 = l1 + 1 + l1 = l1 + 1 if (size(lval) < l1) then - ! + ! ! Figure out a good reallocation size! - ! + ! isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -1046,25 +1046,25 @@ contains lja(l1) = xwid(k) lval(l1) = xw(indx(k)) end do - + ! ! Make sure idxp points to the diagonal entry ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do idxp = idxp + 1 if (idxp > nidx) exit if (idxs(idxp) >= i) exit end do end if end if - if (idxp > size(idxs)) then + if (idxp > size(idxs)) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' else - if (idxs(idxp) > i) then + if (idxs(idxp) > i) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then + else if (idxs(idxp) /= i) then !!$ write(0,*) 'Warning: impossible error: diagonal has vanished' else ! @@ -1076,7 +1076,7 @@ contains if (abs(d(i)) < s_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) @@ -1092,7 +1092,7 @@ contains end if ! - ! Now the upper part + ! Now the upper part ! call heap%init(info,dir=psb_asort_down_) @@ -1104,15 +1104,15 @@ contains nz = 0 do - + idxp = idxp + 1 if (idxp > nidx) exit widx = idxs(idxp) - if (widx <= i) then + if (widx <= i) then !!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) cycle end if - if (widx > m) then + if (widx > m) then !!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) cycle end if @@ -1120,12 +1120,12 @@ contains ! ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle end if nz = nz + 1 - xw(nz) = witem + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1133,7 +1133,7 @@ contains call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 end if - + end do ! @@ -1141,7 +1141,7 @@ contains ! we include entry jmaxup. ! if (nz <= nup+fill_in) then - ! + ! ! Just copy everything from xw ! fndmaxup=.true. @@ -1155,13 +1155,13 @@ contains if (widx == jmaxup) fndmaxup=.true. end do end if - if ((i psb_s_invk_bld + use psb_s_ilu_fact_mod + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_sspmat_type), intent(inout) :: lmat, umat + real(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_sspmat_type) :: atmp + real(psb_spk_), allocatable :: pq(:), pd(:) + integer(psb_ipk_), allocatable :: uplevs(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + character(len=20) :: name, ch_err + + + info = psb_success_ + name='psb_sinvk_bld' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + + call psb_iluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + !,uplevs=uplevs) + !call psb_siluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + ! + ! Compute the aprox U^-1 and L^-1 + ! + call psb_sparse_invk(n_row,umat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_sparse_invk(n_row,lmat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_invk_bld + +subroutine psb_ssparse_invk(n,a,z,fill_in,info,inlevs) + + use psb_base_mod + use psb_s_invk_fact_mod, psb_protect_name => psb_ssparse_invk + + integer(psb_ipk_), intent(in) :: n + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:), jz(:) + real(psb_spk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:), idxs(:) + real(psb_spk_), allocatable :: row(:) + type(psb_s_coo_sparse_mat) :: trw + type(psb_s_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx + type(psb_i_heap) :: heap + + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_sp_invk' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + allocate(uplevs(acsr%get_nzeros()),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + uplevs(:) = 0 + row(:) = szero + rowlevs(:) = -(n+1) + + call zcsr%allocate(n,n,n*fill_in) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + call psb_ensure_size(n+1, idxs, info) + + + ! + ! + zcsr%irp(1) = 1 + nzz = 0 + + l2 = 0 + outer: do i = 1, n-1 + ! ZW = e_i + call psb_invk_copyin(i,n,acsr,ione,n,row,rowlevs,heap,ktrw,trw,info,& + & sign=-sone,inlevs=inlevs) + row(i) = sone + rowlevs(i) = 0 + + ! Update loop + call psb_invk_inv(fill_in,i,row,rowlevs,heap,& + & acsr%ja,acsr%irp,acsr%val,uplevs,nidx,idxs,info) + + call psb_invk_copyout(fill_in,i,n,row,rowlevs,nidx,idxs,& + & l2,zcsr%ja,zcsr%irp,zcsr%val,info) + + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = sone + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + call zcsr%set_sorted() + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_ssparse_invk + +subroutine psb_s_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,sign,inlevs) + + use psb_base_mod + use psb_s_invk_fact_mod, psb_protect_name => psb_s_invk_copyin + + implicit none + + ! Arguments + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + real(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act, nz + integer(psb_ipk_), parameter :: nrb=16 + real(psb_spk_) :: sign_ + character(len=20), parameter :: name='invk_copyin' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + if (present(sign)) then + sign_ = sign + else + sign_ = sone + end if + + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + if (present(inlevs)) then + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = inlevs(j) + call heap%insert(k,info) + end if + end do + else + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_invk_copyin + + +subroutine psb_s_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + + use psb_base_mod + use psb_s_invk_fact_mod, psb_protect_name => psb_s_invk_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + real(psb_spk_), allocatable, intent(inout) :: uaspk(:) + real(psb_spk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: j,isz,err_act,int_err(5),idxp + character(len=20), parameter :: name='psb_siluk_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + do idxp=1,nidx + + j = idxs(idxp) + + if (j>=i) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uaspk) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,uaspk,info) + if (info == psb_success_) call psb_realloc(isz,uia1,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uia1(l2) = j + uaspk(l2) = row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = szero + rowlevs(j) = -(m+1) + end if + end do + + uia2(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_invk_copyout + +subroutine psb_sinvk_inv(fill_in,i,row,rowlevs,heap,ja,irp,val,uplevs,& + & nidx,idxs,info) + + use psb_base_mod + use psb_s_invk_fact_mod, psb_protect_name => psb_sinvk_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:),uplevs(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + real(psb_dpk_) :: rwk + + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) then +!!$ write(psb_err_unit,*) 'IINVK: ',i,' returning at ',lastk + return + end if + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= szero).and.(rowlevs(k) <= fill_in)) then + ! + ! Note: since U is scaled while copying it out (see iluk_copyout), + ! we can use rwk in the update below + ! + rwk = row(k) + lrwk = rowlevs(k) + + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Insert the index into the heap for further processing. + ! The fill levels are initialized to a negative value. If we find + ! one, it means that it is an as yet untouched index, so we need + ! to insert it; otherwise it is already on the heap, there is no + ! need to insert it more than once. + ! + if (rowlevs(j)<0) then + call heap%insert(j,info) + if (info /= psb_success_) return + rowlevs(j) = abs(rowlevs(j)) + end if + ! + ! Update row(j) and the corresponding fill level + ! + row(j) = row(j) - rwk * val(jj) + rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1) + end do + + end if + end do + +end subroutine psb_sinvk_inv diff --git a/prec/impl/psb_s_invt_fact.f90 b/prec/impl/psb_s_invt_fact.f90 new file mode 100644 index 00000000..f311860d --- /dev/null +++ b/prec/impl/psb_s_invt_fact.f90 @@ -0,0 +1,739 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! + +subroutine psb_s_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + + use psb_base_mod + use psb_s_invt_fact_mod, psb_protect_name => psb_s_invt_bld + use psb_s_ilu_fact_mod + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_spk_), intent(in) :: thresh + real(psb_spk_), intent(in) :: invthresh + type(psb_sspmat_type), intent(inout) :: lmat, umat + real(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_sspmat_type) :: atmp + real(psb_spk_), allocatable :: pq(:), pd(:), w(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + real(psb_spk_) :: sp_thresh + character(len=20) :: name, ch_err, fname + + + info = psb_success_ + name='psb_sinvt_fact' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),w(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + if (info == 0) call psb_ilut_fact(nzrmax,sp_thresh,& + & a,lmat,umat,pd,info,blck=blck,iscale=psb_ilu_scale_maxval_) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (.false.) then +!!$ if (debug_level >= psb_debug_inner_) then + write(fname,'(a,i0,a)') 'invt-lo-',me,'.mtx' + call lmat%print(fname,head="INVTLOW") + write(fname,'(a,i0,a)') 'invt-up-',me,'.mtx' + call umat%print(fname,head="INVTUPP") + end if + + ! + ! Compute the approx U^-1 and L^-1 + ! + nzrmax = invfill + call psb_ssparse_invt(n_row,umat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_ssparse_invt(n_row,lmat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_invt_bld + +subroutine psb_ssparse_invt(n,a,z,nzrmax,sp_thresh,info) + + use psb_base_mod + use psb_s_invt_fact_mod, psb_protect_name => psb_ssparse_invt + + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:),jz(:) + real(psb_spk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + real(psb_spk_), allocatable :: row(:) + type(psb_s_coo_sparse_mat) :: trw + type(psb_s_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx, nlw,nup,jmaxup + type(psb_i_heap) :: heap + real(psb_spk_) :: alpha, nrmi + character(len=20) :: name='psb_sp_invt' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call zcsr%allocate(n,n,n*nzrmax) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + ! + ! + nzz = 0 + row(:) = szero + rowlevs(:) = 0 + l2 = 0 + zcsr%irp(1) = 1 + + outer: do i = 1, n-1 + ! ZW = e_i + call psb_s_invt_copyin(i,n,acsr,i,ione,n,nlw,nup,jmaxup,nrmi,row,& + & heap,rowlevs,ktrw,trw,info,sign=-sone) + if (info /= 0) exit + row(i) = sone + ! Adjust norm + if (nrmi < sone) then + nrmi = sqrt(sone + nrmi**2) + else + nrmi = nrmi*sqrt(sone+sone/(nrmi**2)) + end if + + call psb_invt_inv(sp_thresh,i,nrmi,row,heap,rowlevs,& + & acsr%ja,acsr%irp,acsr%val,nidx,idxs,info) + if (info /= 0) exit +!!$ write(0,*) 'Calling copyout ',nzrmax,nlw,nup,nidx,l2 + call psb_s_invt_copyout(nzrmax,sp_thresh,i,n,nlw,nup,jmaxup,nrmi,row,& + & nidx,idxs,l2,zcsr%ja,zcsr%irp,zcsr%val,info) + if (info /= 0) exit + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = sone + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_ssparse_invt + +subroutine psb_s_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_d_invt_copyin + implicit none + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(inout) :: nrmi + real(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), intent(in), optional :: sign + ! + integer(psb_ipk_) :: k,j,irb,kin,nz, err_act + integer(psb_ipk_), parameter :: nrb=16 + real(psb_dpk_) :: dmaxup, sign_ + real(psb_dpk_), external :: dnrm2 + character(len=20), parameter :: name='invt_copyin' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + sign_ = sone + if (present(sign)) sign_ = sign + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = szero + nrmi = szero + + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + call heap%insert(k,info) + irwt(k) = 1 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end do + nz = a%irp(i+1) - a%irp(i) + nrmi = dnrm2(nz,a%val(a%irp(i):),ione) + + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_invt_copyin + +subroutine psb_s_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + + use psb_base_mod + use psb_s_invt_fact_mod, psb_protect_name => psb_s_invt_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_spk_), intent(in) :: thres,nrmi + real(psb_spk_),allocatable, intent(inout) :: val(:) + real(psb_spk_), intent(inout) :: row(:) + + ! Local variables + real(psb_dpk_),allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + real(psb_dpk_) :: witem, wmin + integer(psb_ipk_) :: widx + integer(psb_ipk_) :: k,isz,err_act,int_err(5),idxp, nz + type(psb_d_idx_heap) :: heap + character(len=20), parameter :: name='invt_copyout' + character(len=20) :: ch_err + logical :: fndmaxup + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + ! + ! Here we need to apply also the dropping rule base on the fill-in. + ! We do it by putting into a heap the elements that are not dropped + ! by using the 2-norm rule, and then copying them out. + ! + ! The heap goes down on the entry absolute value, so the first item + ! is the largest absolute value. + ! +!!$ write(0,*) 'invt_copyout ',nidx,nup+fill_in + call heap%init(info,dir=psb_asort_down_) + + if (info == psb_success_) allocate(xwid(nidx),xw(nidx),indx(nidx),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/3*nidx/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + ! + ! First the lower part + ! + + nz = 0 + idxp = 0 + + do + + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + if (nz > 1) then + write(psb_err_unit,*) 'Warning: lower triangle from invt???? ' + end if + + + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + idxp = idxp - 1 + nz = 0 + wmin=HUGE(wmin) + if (.false.) then + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if ((widx/=jmaxup).and.(nz > nup+fill_in)) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if (nz > nup+fill_in) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz > nup+fill_in) then + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + end do + end if + end if + + ! + ! Now we put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the upper part of the row + ! + do k=1,nz + l2 = l2 + 1 + if (size(val) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,val,info) + if (info == psb_success_) call psb_realloc(isz,ja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + ja(l2) = xwid(k) + val(l2) = xw(indx(k)) + end do + + ! + ! Set row to zero + ! + do idxp=1,nidx + row(idxs(idxp)) = szero + end do + + irp(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_s_invt_copyout + +subroutine psb_s_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val,nidx,idxs,info) + + use psb_base_mod + use psb_s_invt_fact_mod, psb_protect_name => psb_s_invt_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: row(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + real(psb_dpk_) :: rwk, alpha + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + irwt(i) = 1 +!!$ write(0,*) 'Drop Threshold ',thres*nrmi + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! Should not happen, but just in case. + ! + if (k == lastk) cycle + lastk = k + + ! + ! Dropping rule based on the threshold: compare the absolute + ! value of each updated entry of row with thres * 2-norm of row. + ! + rwk = row(k) + + if (abs(rwk) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(k) = dzero + irwt(k) = 0 + cycle + else + ! + ! Note: since U is scaled while copying it out (see ilut_copyout), + ! we can use rwk in the update below. + ! + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Update row(j) and, if it is not to be discarded, insert + ! its index into the heap for further processing. + ! + row(j) = row(j) - rwk * val(jj) + if (irwt(j) == 0) then + if (abs(row(j)) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(j) = dzero + else + ! + ! Do the insertion. + ! + call heap%insert(j,info) + if (info /= psb_success_) return + irwt(j) = 1 + end if + end if + end do + end if + + ! + ! If we get here it is an index we need to keep on copyout. + ! + + nidx = nidx + 1 + call psb_ensure_size(nidx,idxs,info,addsz=psb_heap_resize) + if (info /= psb_success_) return + idxs(nidx) = k + irwt(k) = 0 + end do + + irwt(i) = 0 +end subroutine psb_s_invt_inv diff --git a/prec/impl/psb_s_prec_type_impl.f90 b/prec/impl/psb_s_prec_type_impl.f90 index 547272a0..4272ba75 100644 --- a/prec/impl/psb_s_prec_type_impl.f90 +++ b/prec/impl/psb_s_prec_type_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,14 +27,14 @@ ! 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. -! -! -! +! +! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -46,7 +46,7 @@ !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific 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 @@ -58,14 +58,14 @@ !!$ 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. -!!$ -!!$ +!!$ +!!$ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine psb_s_apply2_vect(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_s_prec_type, psb_protect_name => psb_s_apply2_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_sprec_type), intent(inout) :: prec type(psb_s_vect_type),intent(inout) :: x @@ -74,9 +74,10 @@ subroutine psb_s_apply2_vect(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans real(psb_spk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ real(psb_spk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -84,28 +85,28 @@ subroutine psb_s_apply2_vect(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -114,13 +115,13 @@ subroutine psb_s_apply2_vect(prec,x,y,desc_data,info,trans,work) call prec%prec%apply(sone,x,szero,y,desc_data,info,& & trans=trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -135,7 +136,7 @@ end subroutine psb_s_apply2_vect subroutine psb_s_apply1_vect(prec,x,desc_data,info,trans,work) use psb_base_mod use psb_s_prec_type, psb_protect_name => psb_s_apply1_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_sprec_type), intent(inout) :: prec type(psb_s_vect_type),intent(inout) :: x @@ -144,9 +145,10 @@ subroutine psb_s_apply1_vect(prec,x,desc_data,info,trans,work) real(psb_spk_),intent(inout), optional, target :: work(:) type(psb_s_vect_type) :: ww - character :: trans_ + character :: trans_ real(psb_spk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -154,28 +156,28 @@ subroutine psb_s_apply1_vect(prec,x,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -186,13 +188,13 @@ subroutine psb_s_apply1_vect(prec,x,desc_data,info,trans,work) & trans=trans_,work=work_) if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info) call psb_gefree(ww,desc_data,info) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -207,7 +209,7 @@ end subroutine psb_s_apply1_vect subroutine psb_s_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_s_prec_type, psb_protect_name => psb_s_apply2v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_sprec_type), intent(inout) :: prec real(psb_spk_),intent(inout) :: x(:) @@ -216,9 +218,10 @@ subroutine psb_s_apply2v(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans real(psb_spk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ real(psb_spk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -226,40 +229,40 @@ subroutine psb_s_apply2v(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=trans else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if call prec%prec%apply(sone,x,szero,y,desc_data,info,trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -274,7 +277,7 @@ end subroutine psb_s_apply2v subroutine psb_s_apply1v(prec,x,desc_data,info,trans) use psb_base_mod use psb_s_prec_type, psb_protect_name => psb_s_apply1v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_sprec_type), intent(inout) :: prec real(psb_spk_),intent(inout) :: x(:) @@ -282,43 +285,42 @@ subroutine psb_s_apply1v(prec,x,desc_data,info,trans) character(len=1), optional :: trans character :: trans_ - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act real(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_s_apply1v' info = psb_success_ call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if call prec%prec%apply(sone,x,szero,ww,desc_data,info,& & trans_,work=w1) if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if @@ -332,3 +334,159 @@ subroutine psb_s_apply1v(prec,x,desc_data,info,trans) end subroutine psb_s_apply1v +subroutine psb_scprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_s_prec_type, psb_protect_name => psb_scprecseti + implicit none + + class(psb_sprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precseti' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_FILLIN') + call prec%prec%precset(psb_ilu_fill_in_,val,info) + case ('INV_FILLIN') + call prec%prec%precset(psb_inv_fillin_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_scprecseti + +subroutine psb_scprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_s_prec_type, psb_protect_name => psb_scprecsetr + implicit none + + class(psb_sprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetr' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case('SUB_ILUTHRS') + call prec%prec%precset(psb_fact_eps_,val,info) + case('INV_THRESH') + call prec%prec%precset(psb_inv_thresh_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_scprecsetr + +subroutine psb_scprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_s_prec_type, psb_protect_name => psb_scprecsetc + implicit none + + class(psb_sprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetc' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_SOLVE') + ! We select here the type of solver on the block + select case (psb_toupper(trim(string))) + case("ILU") + call prec%prec%precset(psb_f_type_,psb_f_ilu_k_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + case("ILUT") + call prec%prec%precset(psb_f_type_,psb_f_ilu_t_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_t_,info) + case("AINV") + call prec%prec%precset(psb_f_type_,psb_f_ainv_,info) + case("INVK") + call prec%prec%precset(psb_f_type_,psb_f_invk_,info) + case("INVT") + call prec%prec%precset(psb_f_type_,psb_f_invt_,info) + case default + ! Default to ILU(0) factorization + call prec%prec%precset(psb_f_type_,psb_f_ilu_n_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + end select + case ("ILU_ALG") + select case (psb_toupper(trim(string))) + case ("MILU") + call prec%prec%precset(psb_ilu_ialg_,psb_milu_n_,info) + case default + ! Do nothing + end select + case ("ILUT_SCALE") + select case (psb_toupper(trim(string))) + case ("MAXVAL") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_maxval_,info) + case ("DIAG") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_diag_,info) + case ("ARWSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arwsum_,info) + case ("ARCSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arcsum_,info) + case ("ACLSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_aclsum_,info) + case ("NONE") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + case default + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + end select + case ("AINV_ALG") + select case (psb_toupper(trim(string))) + case("LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + case("SYM-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_llk_,info) + case("STAB-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_ft_llk_,info) + case("MLK","LMX") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_mlk_,info) + case default + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + end select + case default + + end select + +end subroutine psb_scprecsetc diff --git a/prec/impl/psb_s_sp_drop.f90 b/prec/impl/psb_s_sp_drop.f90 new file mode 100644 index 00000000..bc297d08 --- /dev/null +++ b/prec/impl/psb_s_sp_drop.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_s_sp_drop(idiag,nzrmax,sp_thresh,nz,iz,valz,info) + use psb_base_mod + implicit none + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, nzrmax + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: iz(:) + real(psb_spk_), intent(inout) :: valz(:) + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i, j, idf, nw + real(psb_spk_) :: witem + integer(psb_ipk_) :: widx + real(psb_spk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + + if (nz > min(size(iz),size(valz))) then + write(0,*) 'Serious size problem ',nz,size(iz),size(valz) + info = -2 + return + end if + allocate(xw(nz),xwid(nz),indx(nz),stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory allocation failure in sp_drop',nz,info + return + endif + + ! Always keep the diagonal element + idf = -1 + do i=1, nz + if (iz(i) == idiag) then + idf = i + witem = valz(i) + widx = iz(i) + valz(i) = valz(1) + iz(i) = iz(1) + valz(1) = witem + iz(1) = widx + exit + end if + end do + + if (idf == -1) then + + xw(1:nz) = valz(1:nz) + call psb_qsort(xw(1:nz),indx(1:nz),dir=psb_asort_down_) + do i=1, nz + xwid(i) = iz(indx(i)) + end do + nw = min(nz,nzrmax) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + nw = max(nw, 1) + + else + + nw = nz-1 + + xw(1:nw) = valz(2:nz) + + call psb_qsort(xw(1:nw),indx(1:nw),dir=psb_asort_down_) + nw = min(nw,nzrmax-1) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + + do i=1, nw + xwid(i) = iz(1+indx(i)) + end do + nw = nw + 1 + xw(nw) = valz(1) + xwid(nw) = iz(1) + end if + + call psb_msort(xwid(1:nw),indx(1:nw),dir=psb_sort_up_) + + do i=1, nw + valz(i) = xw(indx(i)) + iz(i) = xwid(i) + end do + nz = nw + if (nz>nzrmax) write(0,*) 'in sp_drop: ',nw,nzrmax,nz + deallocate(xw,xwid,indx,stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory deallocation failure in sp_drop',info + return + endif + return +end subroutine psb_s_sp_drop diff --git a/prec/impl/psb_s_sparsify.f90 b/prec/impl/psb_s_sparsify.f90 new file mode 100644 index 00000000..f829fbf2 --- /dev/null +++ b/prec/impl/psb_s_sparsify.f90 @@ -0,0 +1,260 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_s_sparsify(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,info,istart,iheap,ikr) + use psb_base_mod + implicit none + + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_spk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_spk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: istart + type(psb_i_heap), optional :: iheap + integer(psb_ipk_), optional :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k + real(psb_spk_) :: witem + integer(psb_ipk_) :: widx + real(psb_spk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + type(psb_s_idx_heap) :: heap + + + info = psb_success_ + istart_ = 1 + if (present(istart)) istart_ = max(1,istart) + if (.false.) then + nz = 0 + do i=istart_, n + if ((i == idiag).or.(abs(zw(i)) >= sp_thresh)) then + nz = nz + 1 + iz(nz) = i + valz(nz) = zw(i) + end if + end do + + else + allocate(xw(nzrmax),xwid(nzrmax),indx(nzrmax),stat=info) + if (info /= psb_success_) then + return + end if + + call heap%init(info,dir=psb_asort_down_) + + ! Keep at least the diagonal + nz = 0 + + if (present(iheap)) then + if (.not.(present(ikr))) then + write(psb_err_unit,*) 'Error: if IHEAP then also IKR' + info = -1 + return + end if + last_i = -1 + do + call iheap%get_first(i,iret) + if (iret < 0) exit + ! An index may have been put on the heap more than once. + if (i == last_i) cycle + last_i = i + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + ikr(i) = 0 + end do + + else + + do i=istart_, n + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + end do + end if + + k = 1 + do + if (k == nzrmax) exit + call heap%get_first(witem,widx,info) + if (info == -1) then + info = psb_success_ + exit + endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + k = k + 1 + xw(k) = witem + xwid(k) = widx + end do + call heap%free(info) + nz = k + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + end if + + return + +end subroutine psb_s_sparsify + + +subroutine psb_s_sparsify_list(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,lhead,listv,ikr,info) + use psb_base_mod + implicit none + + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_spk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_spk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: lhead, listv(:) + integer(psb_ipk_) :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k,current, next + real(psb_spk_) :: witem + integer(psb_ipk_) :: widx + real(psb_spk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + istart_ = 1 + allocate(xw(n),xwid(n),indx(n),stat=info) + + current = lhead + lhead = -1 + i = 0 + do while (current >0) + i = i + 1 + xw(i) = zw(current) + xwid(i) = current + + if (current == idiag) then + ! Bring the diagona into first position + witem = xw(1) + widx = xwid(1) + xw(1) = xw(i) + xwid(1) = xwid(i) + xw(i) = witem + xwid(i) = widx + end if + + zw(current) = dzero + ikr(current) = 0 + + next = listv(current) + listv(current) = -1 + current = next + end do + nz = i + if (nz > 2) call psb_hsort(xw(2:nz),ix=xwid(2:nz),& + & dir=psb_asort_down_,flag=psb_sort_keep_idx_) +!!$ write(0,*) 'Done first msort ' +!!$ write(0,*) ' after first msort for idiag ',idiag,' :',nz,sp_thresh +!!$ do i=1, nz +!!$ write(0,*) ' ',xwid(i),xw(i) +!!$ end do + + i = 2 + do while (i<=nz) + if (abs(xw(i)) < sp_thresh) exit + i = i + 1 + end do +!!$ write(0,*) 'NZ ',nz, i, nzrmax + nz = max(1,min(i-1,nzrmax)) + call psb_msort(xwid(1:nz),ix=indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'Done second msort ' + +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,i,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + return + +end subroutine psb_s_sparsify_list diff --git a/prec/impl/psb_sprecbld.f90 b/prec/impl/psb_sprecbld.f90 index 8cc48eab..a878c16c 100644 --- a/prec/impl/psb_sprecbld.f90 +++ b/prec/impl/psb_sprecbld.f90 @@ -44,7 +44,8 @@ subroutine psb_sprecbld(a,desc_a,p,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local scalars - integer(psb_ipk_) :: ictxt, me,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err @@ -58,9 +59,9 @@ subroutine psb_sprecbld(a,desc_a,p,info,amold,vmold,imold) end if info = psb_success_ - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() diff --git a/prec/impl/psb_sprecinit.f90 b/prec/impl/psb_sprecinit.f90 index fa5b83c2..32641bbb 100644 --- a/prec/impl/psb_sprecinit.f90 +++ b/prec/impl/psb_sprecinit.f90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psb_sprecinit(ictxt,p,ptype,info) +subroutine psb_sprecinit(ctxt,p,ptype,info) use psb_base_mod use psb_s_prec_type, psb_protect_name => psb_sprecinit @@ -37,7 +37,7 @@ subroutine psb_sprecinit(ictxt,p,ptype,info) use psb_s_diagprec, only : psb_s_diag_prec_type use psb_s_bjacprec, only : psb_s_bjac_prec_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_sprec_type), intent(inout) :: p character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -50,7 +50,7 @@ subroutine psb_sprecinit(ictxt,p,ptype,info) if (info /= psb_success_) return end if - p%ictxt = ictxt + p%ctxt = ctxt select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NONE','NOPREC') diff --git a/prec/impl/psb_srwclip.f90 b/prec/impl/psb_srwclip.f90 new file mode 100644 index 00000000..f57207d7 --- /dev/null +++ b/prec/impl/psb_srwclip.f90 @@ -0,0 +1,90 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_s_rwclip(nz,ia,ja,val,imin,imax,jmin,jmax) + use psb_base_mod + + implicit none + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: ia(*), ja(*) + real(psb_spk_), intent(inout) :: val(*) + integer(psb_ipk_), intent(in) :: imin,imax,jmin,jmax + + integer(psb_ipk_) :: i,j + + j = 0 + do i=1, nz + if ((imin <= ia(i)).and.& + & (ia(i) <= imax).and.& + & (jmin <= ja(i)).and.& + & (ja(i) <= jmax) ) then + j = j + 1 + ia(j) = ia(i) + ja(j) = ja(i) + val(j) = val(i) + end if + end do + nz = j +end subroutine psb_s_rwclip diff --git a/prec/impl/psb_ssparse_biconjg_llk.F90 b/prec/impl/psb_ssparse_biconjg_llk.F90 new file mode 100644 index 00000000..6269cdc8 --- /dev/null +++ b/prec/impl/psb_ssparse_biconjg_llk.F90 @@ -0,0 +1,366 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_ssparse_biconjg_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_s_ainv_tools_mod + use psb_s_biconjg_mod, psb_protect_name => psb_ssparse_biconjg_llk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + real(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + real(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_s_csc_sparse_mat) :: ac + real(psb_spk_) :: alpha + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = szero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = szero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = sone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = sone + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = szero + ! !$ end do + zval(i) = sone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then +!!$ write(0,*) i, ' Outer inserting ',ac%ia(j) + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! ! write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha + if (.false..or.(abs(alpha) > sp_thresh)) then +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_ssparse_biconjg_llk_noth + + ! + ! Left-looking variant, with NO drop rule on p(i)/p(j) + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + real(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + real(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_s_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_orth_llk_noth' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = szero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = szero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = done + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = szero + ! !$ end do + zval(i) = done + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.true.) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.true.) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_ssparse_biconjg_mlk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + real(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:), hlist(:), bfr(:), rwlist(:) + real(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, hlhead, li, mj, kkc, ifrst, ilst, rwhead + type(psb_i_heap) :: heap, rheap + type(psb_s_csc_sparse_mat) :: ac + real(psb_spk_) :: alpha + character(len=20) :: name='psb_biconjg_mlk' + logical, parameter :: debug=.false., test_merge=.true. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n), & + & hlist(n),rwlist(n),bfr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = szero + hlist(i) = -1 + rwlist(i) = -1 + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = szero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = sone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = sone + nzw = 1 + + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = szero + ! !$ end do + zval(i) = sone + izkr(i) = 1 + rwhead = i + + hlhead = -1 + + kkc = 0 + ilst = ac%icp(i)-1 + ifrst = ac%icp(i) + do j = ac%icp(i+1)-1, ac%icp(i), -1 + if (ac%ia(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (.true..or.debug) then +!!$ write(0,*) 'Outer Before insertion : ',hlhead + call printlist(hlhead,hlist) + end if + if (kkc > 0) then +!!$ write(0,*) i,' Outer Inserting : ',kkc,':',ac%ia(ifrst:ilst) + + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + mj = hlhead + if (mj > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outer + + izcr(j) = 0 + if (j>=i) cycle outer + + if (debug) write(0,*) 'update loop, using row: ',j,i,mj + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha +!!$ write(0,*) ' Current list is : ',hlhead +!!$ call printlist(hlhead,hlist) +!!$ + + + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=z%icp(j) + ilst=z%icp(j+1)-1 + call hlmerge(rwhead,rwlist,z%ia(ifrst:ilst)) +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr +!!$ call hlmerge(rwhead,rwlist,(/kr/)) + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',ac%ia(ifrst:ilst) + end if + if (ilst >= ifrst) then +!!$ write(0,*) j,i,' Inner inserting ',ac%ia(ifrst:ilst) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outer + call a%csget(i,i,nzra,ia,ja,val,info) + call rwclip(nzra,ia,ja,val,ione,n,ione,n) + p(i) = psb_spge_dot(nzra,ja,val,zval) + if (abs(p(i)) < s_epstol) & + & p(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzz+nzrz, z%ia, info) + call psb_ensure_size(nzz+nzrz, z%val, info) + ipz1 = z%icp(i) + do j=1, nzrz + z%ia(ipz1 + j -1) = ia(j) + z%val(ipz1 + j -1) = val(j) + end do + z%icp(i+1) = ipz1 + nzrz + nzz = nzz + nzrz + + + ! WVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = szero + ! !$ end do + zval(i) = sone + izkr(i) = 1 + rwhead = i + hlhead = -1 + + kkc = 0 + ilst = a%irp(i)-1 + ifrst = a%irp(i) + do j = a%irp(i+1)-1, a%irp(i), -1 + if (a%ja(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (debug) then + write(0,*) 'Outer Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Outer Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + if (kkc > 0 ) then + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outerw: do + mj = hlhead + if (hlhead > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outerw + + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=w%icp(j) + ilst=w%icp(j+1)-1 + call hlmerge(rwhead,rwlist,w%ia(ifrst:ilst)) + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + if (debug) write(0,*) 'update loop, adding indices: ',& + & a%ja(a%irp(kr):a%irp(kr+1)-1) + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outerw + ip1 = ac%icp(i) + ip2 = ac%icp(i+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + if (abs(q(i)) < s_epstol) & + & q(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzw+nzrz, w%ia, info) + call psb_ensure_size(nzw+nzrz, w%val, info) + ipz1 = w%icp(i) + do j=1, nzrz + w%ia(ipz1 + j -1) = ia(j) + w%val(ipz1 + j -1) = val(j) + end do + w%icp(i+1) = ipz1 + nzrz + nzw = nzw + nzrz + + end do + +contains + + subroutine hlmerge(head,listv,vals) + integer(psb_ipk_), intent(inout) :: head, listv(:) + integer(psb_ipk_), intent(in) :: vals(:) + integer(psb_ipk_) :: i,j,k, lh, lv, nv, vv, flh, ph + + nv = size(vals) + lh = head + flh = -1 + lv = 1 + if ((head < 0).and.(nv > 0)) then + ! Adjust head if empty + head = vals(lv) + lv = lv + 1 + else if ((head > 0) .and. (nv >0)) then + ! Adjust head if first item less than it + if (head > vals(lv)) then + listv(vals(lv)) = head + head = vals(lv) + lv = lv + 1 + end if + end if + + lh = head + ph = lh + do while ((lh > 0) .and. (lv <= nv)) + if (lh == vals(lv)) then + lv = lv + 1 + else if (lh > vals(lv)) then + listv(vals(lv)) = lh + listv(ph) = vals(lv) + lh = vals(lv) + lv = lv + 1 + else + ph = lh + lh = listv(lh) + end if + end do + lh = ph + do while (lv <= nv) + listv(lh) = vals(lv) + lh = listv(lh) + lv = lv + 1 + end do + end subroutine hlmerge + + + subroutine printlist(head,listv) + integer(psb_ipk_), intent(in) :: head, listv(:) + integer(psb_ipk_) :: li + + li = head + do while (li > 0) + write(0,*) 'Item: ', li + li = listv(li) + end do + end subroutine printlist + +end subroutine psb_ssparse_biconjg_mlk diff --git a/prec/impl/psb_ssparse_biconjg_s_ft_llk.F90 b/prec/impl/psb_ssparse_biconjg_s_ft_llk.F90 new file mode 100644 index 00000000..e8287e84 --- /dev/null +++ b/prec/impl/psb_ssparse_biconjg_s_ft_llk.F90 @@ -0,0 +1,414 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_ssparse_biconjg_s_ft_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_s_ainv_tools_mod + use psb_s_biconjg_mod, psb_protect_name => psb_ssparse_biconjg_s_ft_llk + + ! + ! Left-looking variant, stabilized i.e. product by A is applied + ! to compute the diagonal elements. + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + real(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:),iww(:) + real(psb_spk_), allocatable :: zval(:),val(:), q(:), ww(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj, nzww,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, nzrw + type(psb_i_heap) :: heap, rheap + type(psb_s_csc_sparse_mat) :: ac + real(psb_spk_) :: alpha, tmpq,tmpq2 + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),iww(n),ww(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! Init pointers to: + ! ljr(i): last occupied column index within row I + ! izcr(i): first occupied row index within column I + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = szero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = szero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = sone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = sone + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = szero + ! !$ end do + zval(i) = sone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) lastj) then + lastj = j + exit inner + end if + end do inner + izcr(j) = 0 + if (j>=i) exit outer + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = w%icp(j) + ip2 = w%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_s_spvspm(sone,a,nzra,w%ia(ip1:ip2),w%val(ip1:ip2),& + & szero,nzww,iww,ww,info) + + p(i) = psb_spge_dot(nzww,iww,ww,zval) + + ipz1 = z%icp(j) + ipz2 = z%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-p(i)/p(j)) +!!$ write(0,*) ' p(i)/p(j) ',i,j,alpha,p(i),p(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) exit outerw + if (debug) write(0,*) 'update loop, using row: ',j + if (.false.) then + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + else + ip1 = z%icp(j) + ip2 = z%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_s_spmspv(sone,ac,nzra,z%ia(ip1:ip2),z%val(ip1:ip2),& + & szero,nzww,iww,ww,info) + + q(i) = psb_spge_dot(nzww,iww,ww,zval) + end if + + ipz1 = w%icp(j) + ipz2 = w%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-q(i)/q(j)) +!!$ write(0,*) ' q(i)/q(j) ',i,j,alpha,q(i),q(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_ssparse_biconjg_s_llk + + ! + ! Left-looking variant SYMMETRIC/HERMITIAN A. You have been warned! + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + real(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + real(psb_spk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw,kk + type(psb_i_heap) :: heap, rheap + type(psb_s_csc_sparse_mat) :: ac + real(psb_spk_) :: alpha, zvalmax + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = szero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = szero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < s_epstol) & + & p(1) = 1.d-3 + + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = sone + nzz = 1 + zvalmax = sone + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = szero + ! !$ end do + zval(i) = sone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.false..or.(abs(alpha) > sp_thresh)) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) +!!$ if (abs(zval(kr)) > 1e16) then +!!$ write(0,*) i,j,p(i),p(j),alpha,z%val(k),alpha*z%val(k),kr,zval(kr) +!!$ end if + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + iscale_ = psb_ilu_scale_none_ + if (present(iscale)) iscale_ = iscale + weight = zone + ! + ! Check the memory available to hold the W and Z factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = desc%get_local_rows() + allocate(pq(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + ! + ! Ok, let's start first with Z (i.e. Upper) + ! + call a%csclip(acoo,info,imax=n_row,jmax=n_row) + call acsr%mv_from_coo(acoo,info) + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + + case(psb_ilu_scale_maxval_) + weight = acsr%maxval() + weight = zone/weight + call acsr%scal(weight,info) + + case(psb_ilu_scale_arcsum_) + allocate(arws(n_row),acls(n_row),ad(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + call acsr%arwsum(arws) + call acsr%aclsum(acls) + ad(1:n_row) = sqrt(sqrt(arws(1:n_row)*acls(1:n_row))) + ad(1:n_row) = zone/ad(1:n_row) + call acsr%scal(ad,info,side='L') + call acsr%scal(ad,info,side='R') + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + ! + ! Here for the actual workhorses. + ! Only biconjg is surviving for now.... + ! + call psb_sparse_biconjg(alg,n_row,acsr,pq,& + & zmat,wmat,nzrmax,sp_thresh,info) + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparse_biconjg') + goto 9999 + end if + call atmp%mv_from(acsr) + + ! + ! Is this right??? + ! + do i=1, n_row + if (abs(pq(i)) < d_epstol) then + pq(i) = zone + else + pq(i) = zone/pq(i) + end if + end do + + select case(iscale_) + case(psb_ilu_scale_none_) + ! Ok, do nothing. + case(psb_ilu_scale_maxval_) + pq(:) = pq(:)*weight + + case(psb_ilu_scale_arcsum_) + call zmat%scal(ad,info,side='L') + call wmat%scal(ad,info,side='R') + + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong iscale') + goto 9999 + end select + + call psb_move_alloc(pq,d,info) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_ainv_bld diff --git a/prec/impl/psb_z_bjacprec_impl.f90 b/prec/impl/psb_z_bjacprec_impl.f90 index b70018f4..93d308d4 100644 --- a/prec/impl/psb_z_bjacprec_impl.f90 +++ b/prec/impl/psb_z_bjacprec_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,28 +27,29 @@ ! 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. -! -! +! +! subroutine psb_z_bjac_dump(prec,info,prefix,head) use psb_base_mod use psb_z_bjacprec, psb_protect_name => psb_z_bjac_dump - implicit none + implicit none class(psb_z_bjac_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than - ! len of prefix_ + ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) - if (present(prefix)) then + if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) else prefix_ = "dump_fact_z" @@ -73,7 +74,7 @@ end subroutine psb_z_bjac_dump subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_z_bjacprec, psb_protect_name => psb_z_bjac_apply_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_z_bjac_prec_type), intent(inout) :: prec complex(psb_dpk_),intent(in) :: alpha,beta @@ -87,7 +88,8 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) integer(psb_ipk_) :: n_row,n_col complex(psb_dpk_), pointer :: ww(:), aux(:) type(psb_z_vect_type) :: wv, wv1 - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit logical :: do_alloc_wrk @@ -99,8 +101,8 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -116,12 +118,12 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (x%get_nrows() < n_row) then + if (x%get_nrows() < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (y%get_nrows() < n_row) then + if (y%get_nrows() < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -138,9 +140,9 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) @@ -150,19 +152,19 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) allocate(ww(n_col),aux(4*n_col),stat=info) endif - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if do_alloc_wrk = .not.prec%is_allocated_wrk() if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate (wv => prec%wrk(1), wv1 => prec%wrk(2)) - + select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) - + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) + select case(trans_) case('N') call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,wv,desc_data,info,& @@ -170,31 +172,58 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + case('T') call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,wv,desc_data,info,& & trans=trans_,scale='L',diag=prec%dv,choice=psb_none_, work=aux) if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + case('C') - + call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,wv,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) - + call wv1%mlt(zone,prec%dv,wv,zzero,info,conjgx=trans_) - + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),wv1,& & beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - + + end select + if (info /= psb_success_) then + ch_err="psb_spsm" + goto 9999 + end if + + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + case('N') + call psb_spmm(zone,prec%av(psb_l_pr_),x,zzero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + if (info == psb_success_) call wv1%mlt(zone,prec%dv,wv,zzero,info) + if(info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1,& + & beta,y,desc_data,info, trans=trans_, work=aux,doswap=.false.) + + case('T','C') + call psb_spmm(zone,prec%av(psb_l_pr_),x,zzero,wv,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + if (info == psb_success_) call wv1%mlt(zone,prec%dv,wv,zzero,info) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),wv1, & + & beta,y,desc_data,info,trans=trans_,work=aux,doswap=.false.) + end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if - + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') @@ -202,12 +231,12 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) end select end associate - + call psb_halo(y,desc_data,info,data=psb_comm_mov_) if (do_alloc_wrk) call prec%free_wrk(info) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -229,7 +258,7 @@ end subroutine psb_z_bjac_apply_vect subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) use psb_base_mod use psb_z_bjacprec, psb_protect_name => psb_z_bjac_apply - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_z_bjac_prec_type), intent(inout) :: prec complex(psb_dpk_),intent(in) :: alpha,beta @@ -242,7 +271,9 @@ subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) ! Local variables integer(psb_ipk_) :: n_row,n_col complex(psb_dpk_), pointer :: ww(:), aux(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_d_vect_type) :: tx,ty + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act, ierr(5) integer(psb_ipk_) :: debug_level, debug_unit character :: trans_ @@ -253,8 +284,8 @@ subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) trans_ = psb_toupper(trans) @@ -270,12 +301,12 @@ subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() - if (size(x) < n_row) then + if (size(x) < n_row) then info = 36; ierr(1) = 2; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(y) < n_row) then + if (size(y) < n_row) then info = 36; ierr(1) = 3; ierr(2) = n_row; call psb_errpush(info,name,i_err=ierr) goto 9999 @@ -292,29 +323,29 @@ subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) end if - if (n_col <= size(work)) then + if (n_col <= size(work)) then ww => work(1:n_col) - if ((4*n_col+n_col) <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 end if endif select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_) select case(trans_) case('N') @@ -341,11 +372,42 @@ subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) & trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /= psb_success_) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if + case(psb_f_ainv_,psb_f_invt_,psb_f_invk_) + ! Application of approximate inverse preconditioner, just some spmm + + select case(trans_) + + case('N') + call psb_spmm(zone,prec%av(psb_l_pr_),x,zzero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('T') + call psb_spmm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * prec%dv%v%v(1:n_row) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + case('C') + call psb_spmm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + ww(1:n_row) = ww(1:n_row) * conjg(prec%dv%v%v(1:n_row)) + if (info == psb_success_) & + & call psb_spmm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + & trans=trans_,work=aux,doswap=.false.) + + end select + case default info = psb_err_internal_error_ @@ -355,8 +417,8 @@ subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) call psb_halo(y,desc_data,info,data=psb_comm_mov_) - if (n_col <= size(work)) then - if ((4*n_col+n_col) <= size(work)) then + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then else deallocate(aux) endif @@ -394,11 +456,26 @@ subroutine psb_z_bjac_precinit(prec,info) call psb_Errpush(info,name) goto 9999 end if + call psb_realloc(psb_rfpsz,prec%rprcparm,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + end if prec%iprcparm(:) = 0 prec%iprcparm(psb_p_type_) = psb_bjac_ prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ prec%iprcparm(psb_ilu_fill_in_) = 0 + prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_ + prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_ + prec%iprcparm(psb_inv_fillin_) = 0 + prec%iprcparm(psb_ainv_alg_) = psb_ainv_llk_ + + + prec%rprcparm(:) = 0 + prec%rprcparm(psb_fact_eps_) = 1E-1_psb_dpk_ + prec%rprcparm(psb_inv_thresh_) = 1E-1_psb_dpk_ call psb_erractionrestore(err_act) @@ -413,7 +490,8 @@ end subroutine psb_z_bjac_precinit subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) use psb_base_mod - use psb_prec_mod, only : psb_ilu_fct + use psb_z_ilu_fact_mod + use psb_z_ainv_fact_mod use psb_z_bjacprec, psb_protect_name => psb_z_bjac_precbld Implicit None @@ -425,14 +503,16 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) class(psb_z_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold - ! .. Local Scalars .. - integer(psb_ipk_) :: i, m + ! .. Local Scalars .. + integer(psb_ipk_) :: i, m, ialg, fill_in, iscale, inv_fill, iinvalg integer(psb_ipk_) :: ierr(5) character :: trans, unitd - type(psb_z_csr_sparse_mat), allocatable :: lf, uf + type(psb_zspmat_type), allocatable :: lf, uf complex(psb_dpk_), allocatable :: dd(:) + real(psb_dpk_) :: fact_eps, inv_thresh integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me character(len=20) :: name='z_bjac_precbld' character(len=20) :: ch_err @@ -444,9 +524,9 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) info = psb_err_internal_error_ ; goto 9999 end if - ictxt=desc_a%get_ctxt() - call prec%set_ctxt(ictxt) - call psb_info(ictxt, me, np) + ctxt=desc_a%get_ctxt() + call prec%set_ctxt(ctxt) + call psb_info(ctxt, me, np) m = a%get_nrows() if (m < 0) then @@ -458,19 +538,100 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) trans = 'N' unitd = 'U' + ! We check if all the information contained in the preconditioner structure + ! are meaningful, otherwise we give an error and get out of the build + ! procedure + ialg = prec%iprcparm(psb_ilu_ialg_) ! Integer for ILU type algorithm + iinvalg = prec%iprcparm(psb_ainv_alg_) ! Integer for AINV type algorithm + iscale = prec%iprcparm(psb_ilu_scale_) ! Integer for scaling of matrix + fact_eps = prec%rprcparm(psb_fact_eps_) ! Drop-tolerance for factorization + inv_thresh = prec%rprcparm(psb_inv_thresh_) ! Drop-tolerance for inverse + fill_in = prec%iprcparm(psb_ilu_fill_in_) ! Fill-In for factorization + inv_fill = prec%iprcparm(psb_inv_fillin_) ! Fill-In for inverse factorization + + ! Check if the type of scaling is known, pay attention that not all the + ! scalings make sense for all the factorization, if something that does not + ! make sense is required the factorization routine will fail in an + ! unnrecoverable way. + if ((iscale == psb_ilu_scale_none_).or.& + (iscale == psb_ilu_scale_maxval_).or.& + (iscale == psb_ilu_scale_diag_).or.& + (iscale == psb_ilu_scale_arwsum_).or.& + (iscale == psb_ilu_scale_aclsum_).or.& + (iscale == psb_ilu_scale_arcsum_)) then + ! Do nothing: admissible request + else + info=psb_err_from_subroutine_ + ch_err='psb_ilu_scale_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the variant for the AINV is known to the library + if( (prec%iprcparm(psb_f_type_) == psb_f_ainv_).and.(& + & (iinvalg == psb_ainv_llk_).or.(iinvalg == psb_ainv_s_llk_).or. & + & (iinvalg == psb_ainv_s_ft_llk_).or.(iinvalg == psb_ainv_llk_noth_).or.& + & (iinvalg == psb_ainv_mlk_).or.(iinvalg == psb_ainv_lmx_ ) ) ) then + ! Do nothing, these are okay + else + info=psb_err_from_subroutine_ + ch_err='psb_ainv_alg_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Check if the drop-tolerance make sense, if fact_eps > 1 and we are requiring + ! either ILUT, or INVT we give an error. + if( (fact_eps > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ilu_t_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_fact_eps_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! It the drop-tolerance for the inverse factors, inv_thresh > 1 and we are + ! requiring AINV or, or INVT we give an error + if( (inv_thresh > 1).and.( & + & (prec%iprcparm(psb_f_type_) == psb_f_ainv_).or.& + & (prec%iprcparm(psb_f_type_) == psb_f_invt_) )) then + info=psb_err_from_subroutine_ + ch_err='psb_inv_thresh_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ! Checks relative to the fill-in parameters + if (prec%iprcparm(psb_f_type_) == psb_f_ilu_n_) then + if(fill_in < 0) then + info=psb_err_from_subroutine_ + ch_err='psb_ilu_fill_in_' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + else if (fill_in == 0) then + ! If the requested level of fill is equal to zero, we default to the + ! specialized ILU(0) routine + prec%iprcparm(psb_f_type_) = psb_f_ilu_n_ + end if + end if + ! If no limit on the fill_in is required we allow every fill, this is needed + ! since this quantity is used to allocate the auxiliary vectors for the + ! factorization + if (inv_fill <= 0) inv_fill = m + + ! Select on the type of factorization to be used select case(prec%iprcparm(psb_f_type_)) - case(psb_f_ilu_n_) + case(psb_f_ilu_n_) + ! ILU(0) Factorization: the total number of nonzeros of the factorized matrix + ! is equal to the one of the input matrix - if (allocated(prec%av)) then - if (size(prec%av) < psb_bp_ilu_avsz) then - do i=1,size(prec%av) + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) call prec%av(i)%free() enddo deallocate(prec%av,stat=info) endif end if - if (.not.allocated(prec%av)) then + if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -497,27 +658,27 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) end if allocate(dd(n_row),stat=info) - if (info == psb_success_) then + if (info == psb_success_) then allocate(prec%dv, stat=info) - if (info == 0) then - if (present(vmold)) then - allocate(prec%dv%v,mold=vmold,stat=info) - else - allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) end if end if end if - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 + goto 9999 endif - ! This is where we have no renumbering, thus no need - call psb_ilu_fct(a,lf,uf,dd,info) + ! This is where we have no renumbering, thus no need + call psb_ilu0_fact(ialg,a,lf,uf,dd,info) if(info == psb_success_) then - call prec%av(psb_l_pr_)%mv_from(lf) - call prec%av(psb_u_pr_)%mv_from(uf) + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) call prec%av(psb_l_pr_)%set_asb() call prec%av(psb_u_pr_)%set_asb() call prec%av(psb_l_pr_)%trim() @@ -526,12 +687,375 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) ! call move_alloc(dd,prec%d) else info=psb_err_from_subroutine_ - ch_err='psb_ilu_fct' + ch_err='psb_ilu0_fact' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - case(psb_f_none_) + case(psb_f_ilu_k_) + ! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on + ! the type of the variant of the algorithm the may be forgotten or added to + ! the diagonal (MILU) + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ilu_t_) + ! ILU(N,E) Incomplete LU factorization with thresholding and level of fill + + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! This is where we have no renumbering, thus no need + call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_ainv_) + ! Approximate Inverse Factorizations based on variants of the incomplete + ! biconjugation algorithms + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_ainv_fact(a,iinvalg,inv_fill,inv_thresh,lf,dd,uf,desc_a,info,iscale=iscale) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invk_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(n) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invk_fact(a,fill_in, inv_fill,lf,dd,uf,desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_invt_) + ! Approximate Inverse Factorizations based on the sparse inversion of + ! triangular factors of an ILU(eps) factorization + if (allocated(prec%av)) then + if (size(prec%av) < psb_bp_ilu_avsz) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + endif + end if + if (.not.allocated(prec%av)) then + allocate(prec%av(psb_max_avsz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + endif + + nrow_a = desc_a%get_local_rows() + nztota = a%get_nzeros() + + n_col = desc_a%get_local_cols() + nhalo = n_col-nrow_a + n_row = nrow_a + + allocate(lf,uf,stat=info) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + allocate(dd(n_row),stat=info) + if (info == psb_success_) then + allocate(prec%dv, stat=info) + if (info == 0) then + if (present(vmold)) then + allocate(prec%dv%v,mold=vmold,stat=info) + else + allocate(psb_z_base_vect_type :: prec%dv%v,stat=info) + end if + end if + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + endif + ! Computing the factorization + call psb_invt_fact(a,fill_in,inv_fill,fact_eps,inv_thresh,lf,dd,uf,& + & desc_a,info) + + if(info == psb_success_) then + call prec%av(psb_l_pr_)%mv_from(lf%a) + call prec%av(psb_u_pr_)%mv_from(uf%a) + call prec%av(psb_l_pr_)%set_asb() + call prec%av(psb_u_pr_)%set_asb() + call prec%av(psb_l_pr_)%trim() + call prec%av(psb_u_pr_)%trim() + call prec%dv%bld(dd) + ! call move_alloc(dd,prec%d) + else + info=psb_err_from_subroutine_ + ch_err='psb_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(psb_f_none_) info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) @@ -544,7 +1068,7 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) goto 9999 end select - if (present(amold)) then + if (present(amold)) then call prec%av(psb_l_pr_)%cscnv(info,mold=amold) call prec%av(psb_u_pr_)%cscnv(info,mold=amold) end if @@ -563,8 +1087,8 @@ subroutine psb_z_bjac_precseti(prec,what,val,info) Implicit None class(psb_z_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(in) :: what + integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, nrow character(len=20) :: name='z_bjac_precset' @@ -572,34 +1096,33 @@ subroutine psb_z_bjac_precseti(prec,what,val,info) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(prec%iprcparm)) then + if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if select case(what) - case (psb_f_type_) - if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_f_type_) prec%iprcparm(psb_f_type_) = val - case (psb_ilu_fill_in_) - if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.& - & (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then - write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',& - & prec%iprcparm(psb_p_type_),& - & 'ignoring user specification' - return - endif + case (psb_ilu_fill_in_) prec%iprcparm(psb_ilu_fill_in_) = val + case (psb_ilu_ialg_) + prec%iprcparm(psb_ilu_ialg_) = val + + case (psb_ilu_scale_) + prec%iprcparm(psb_ilu_scale_) = val + + case (psb_ainv_alg_) + prec%iprcparm(psb_ainv_alg_) = val + + case(psb_inv_fillin_) + prec%iprcparm(psb_inv_fillin_) = val + case default - write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification' + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what end select @@ -609,3 +1132,45 @@ subroutine psb_z_bjac_precseti(prec,what,val,info) 9999 call psb_error_handler(err_act) return end subroutine psb_z_bjac_precseti + +subroutine psb_z_bjac_precsetr(prec,what,val,info) + + use psb_base_mod + use psb_z_bjacprec, psb_protect_name => psb_z_bjac_precsetr + Implicit None + + class(psb_z_bjac_prec_type),intent(inout) :: prec + integer(psb_ipk_), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, nrow + character(len=20) :: name='z_bjac_precset' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (.not.allocated(prec%rprcparm)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + select case(what) + + case (psb_fact_eps_) + prec%rprcparm(psb_fact_eps_) = val + + case (psb_inv_thresh_) + prec%rprcparm(psb_inv_thresh_) = val + + case default + write(psb_err_unit,'(i0," is invalid, ignoring user specification")') what + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_bjac_precsetr diff --git a/prec/impl/psb_z_diagprec_impl.f90 b/prec/impl/psb_z_diagprec_impl.f90 index 24e288f5..7a20006a 100644 --- a/prec/impl/psb_z_diagprec_impl.f90 +++ b/prec/impl/psb_z_diagprec_impl.f90 @@ -38,15 +38,16 @@ subroutine psb_z_diag_dump(prec,info,prefix,head) integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head integer(psb_ipk_) :: i, j, il1, iln, lname, lev - integer(psb_ipk_) :: ictxt,iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/impl/psb_z_ilu0_fact.f90 b/prec/impl/psb_z_ilu0_fact.f90 index 867da777..26322e95 100644 --- a/prec/impl/psb_z_ilu0_fact.f90 +++ b/prec/impl/psb_z_ilu0_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_zilu0_fact.f90 ! ! Subroutine: psb_zilu0_fact @@ -75,7 +75,7 @@ ! ! This routine computes either the ILU(0) or the MILU(0) factorization of ! the diagonal blocks of a distributed matrix. These factorizations are used -! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, +! to build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a given level of a ! multilevel preconditioner. ! @@ -83,10 +83,10 @@ ! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, ! SIAM, 2003, Chapter 10. ! -! The local matrix is stored into a and blck, as specified in the description -! of the arguments below. The storage format for both the L and U factors is CSR. -! The diagonal of the U factor is stored separately (actually, the inverse of the -! diagonal entries is stored; this is then managed in the solve stage associated +! The local matrix is stored into a and blck, as specified in the description +! of the arguments below. The storage format for both the L and U factors is CSR. +! The diagonal of the U factor is stored separately (actually, the inverse of the +! diagonal entries is stored; this is then managed in the solve stage associated ! to the ILU(0)/MILU(0) factorization). ! ! The routine copies and factors "on the fly" from a and blck into l (L factor), @@ -94,7 +94,7 @@ ! ! This implementation of ILU(0)/MILU(0) is faster than the implementation in ! psb_ziluk_fct (the latter routine performs the more general ILU(k)/MILU(k)). -! +! ! ! Arguments: ! ialg - integer, input. @@ -121,7 +121,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_zspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -129,7 +129,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck is empty. -! +! subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) use psb_base_mod @@ -157,30 +157,30 @@ subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(upd)) then - upd_ = psb_toupper(upd) + if (present(upd)) then + upd_ = psb_toupper(upd) else upd_ = 'F' end if - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -212,12 +212,12 @@ subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() if(info.ne.0) then @@ -226,7 +226,7 @@ subroutine psb_zilu0_fact(ialg,a,l,u,d,info,blck, upd) call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - deallocate(blck_) + deallocate(blck_) endif call psb_erractionrestore(err_act) @@ -243,9 +243,9 @@ contains ! Version: complex ! Note: internal subroutine of psb_zilu0_fact. ! - ! This routine computes either the ILU(0) or the MILU(0) factorization of the - ! diagonal blocks of a distributed matrix. - ! These factorizations are used to build the 'base preconditioner' + ! This routine computes either the ILU(0) or the MILU(0) factorization of the + ! diagonal blocks of a distributed matrix. + ! These factorizations are used to build the 'base preconditioner' ! (block-Jacobi preconditioner/solver, Additive Schwarz ! preconditioner) corresponding to a given level of a multilevel preconditioner. ! @@ -257,7 +257,7 @@ contains ! ! The routine copies and factors "on the fly" from the sparse matrix structures a ! and b into the arrays lval, uval, d (L, U without its diagonal, diagonal of U). - ! + ! ! ! Arguments: ! ialg - integer, input. @@ -296,7 +296,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - complex(psb_dpk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -305,18 +305,18 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output. ! The number of nonzero entries in lval. ! l2 - integer, output. ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_zilu0_factint(ialg,a,b,& & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: ialg @@ -332,7 +332,7 @@ contains complex(psb_dpk_) :: dia,temp integer(psb_ipk_), parameter :: nrb=16 type(psb_z_coo_sparse_mat) :: trw - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: int_err(5) character(len=20) :: name, ch_err name='psb_zilu0_factint' @@ -346,10 +346,10 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione,ialg,izero,izero,izero/)) goto 9999 end select @@ -363,7 +363,7 @@ contains end if m = ma+mb - if (psb_toupper(upd) == 'F' ) then + if (psb_toupper(upd) == 'F' ) then lirp(1) = 1 uirp(1) = 1 l1 = 0 @@ -379,14 +379,14 @@ contains if (i <= ma) then ! ! Copy the i-th local row of the matrix, stored in a, - ! into lval/d(i)/uval + ! into lval/d(i)/uval ! call ilu_copyin(i,ma,a,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) else ! ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into lval/d(i)/uval + ! (as (i-ma)-th row), into lval/d(i)/uval ! call ilu_copyin(i-ma,mb,b,i,ione,m,l1,lja,lval,& & d(i),l2,uja,uval,ktrw,trw,upd) @@ -437,7 +437,7 @@ contains ! dia = dia - temp*uval(jj) cycle updateloop - ! + ! else if (j > i) then ! ! search u(i,*) (i-th row of U) for a matching index j @@ -454,23 +454,23 @@ contains end if enddo end if - ! - ! If we get here we missed the cycle updateloop, which means + ! + ! If we get here we missed the cycle updateloop, which means ! that this entry does not match; thus we accumulate on the ! diagonal for MILU(0). ! - if (ialg == psb_milu_n_) then + if (ialg == psb_milu_n_) then dia = dia - temp*uval(jj) end if enddo updateloop enddo - ! + ! ! Check the pivot size - ! + ! if (abs(dia) < d_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') abs(dia) @@ -493,7 +493,7 @@ contains else write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 @@ -515,7 +515,7 @@ contains ! Version: complex ! Note: internal subroutine of psb_zilu0_fact ! - ! This routine copies a row of a sparse matrix A, stored in the psb_zspmat_type + ! This routine copies a row of a sparse matrix A, stored in the psb_zspmat_type ! data structure a, into the arrays lval and uval and into the scalar variable ! dia, corresponding to the lower and upper triangles of A and to the diagonal ! entry of the row, respectively. The entries in lval and uval are stored @@ -529,14 +529,14 @@ contains ! ! The routine is used by psb_zilu0_factint in the computation of the ILU(0)/MILU(0) ! factorization of a local sparse matrix. - ! + ! ! TODO: modify the routine to allow copying into output L and U that are ! already filled with indices; this would allow computing an ILU(k) pattern, - ! then use the ILU(0) internal for subsequent calls with the same pattern. + ! then use the ILU(0) internal for subsequent calls with the same pattern. ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -570,13 +570,13 @@ contains ! to the CSR storage format. ! uval - complex(psb_dpk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the - ! upper triangle are copied. + ! upper triangle are copied. ! ktrw - integer, input/output. ! The index identifying the last entry taken from the ! staging buffer trw. See below. ! trw - type(psb_zspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -608,10 +608,10 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - if (psb_toupper(upd) == 'F') then + if (psb_toupper(upd) == 'F') then - select type(aa => a%a) - type is (psb_z_csr_sparse_mat) + select type(aa => a%a) + type is (psb_z_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format @@ -633,19 +633,19 @@ contains end if enddo - class default + class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into lval, dia, uval, through ! successive calls to ilu_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) - call aa%csget(i,i+irb-1,trw,info) + call aa%csget(i,i+irb-1,trw,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='csget' @@ -656,7 +656,7 @@ contains end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) @@ -680,7 +680,7 @@ contains write(0,*) 'Update not implemented ' info = 31 - call psb_errpush(info,name,& + call psb_errpush(info,name,& & i_err=(/ione*13,izero,izero,izero,izero/),a_err=upd) goto 9999 diff --git a/prec/impl/psb_z_iluk_fact.f90 b/prec/impl/psb_z_iluk_fact.f90 index fe9e92d9..1a398cda 100644 --- a/prec/impl/psb_z_iluk_fact.f90 +++ b/prec/impl/psb_z_iluk_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_ziluk_fact.f90 ! ! Subroutine: psb_ziluk_fact @@ -74,7 +74,7 @@ ! Contains: psb_ziluk_factint, iluk_copyin, iluk_fact, iluk_copyout. ! ! This routine computes either the ILU(k) or the MILU(k) factorization of the -! diagonal blocks of a distributed matrix. These factorizations are used to +! diagonal blocks of a distributed matrix. These factorizations are used to ! build the 'base preconditioner' (block-Jacobi preconditioner/solver, ! Additive Schwarz preconditioner) corresponding to a certain level of a ! multilevel preconditioner. @@ -88,7 +88,7 @@ ! U factors is CSR. The diagonal of the U factor is stored separately (actually, ! the inverse of the diagonal entries is stored; this is then managed in the solve ! stage associated to the ILU(k)/MILU(k) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -118,7 +118,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_zspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -126,7 +126,7 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_base_mod @@ -143,7 +143,7 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) complex(psb_dpk_), intent(inout) :: d(:) ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act - + type(psb_zspmat_type), pointer :: blck_ type(psb_z_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err @@ -152,17 +152,17 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) info = psb_success_ call psb_erractionsave(err_act) - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -170,7 +170,7 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -203,15 +203,15 @@ subroutine psb_ziluk_fact(fill_in,ialg,a,l,u,d,info,blck) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -280,7 +280,7 @@ contains ! according to the CSR storage format. ! lia2 - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. + ! of the L factor in laspk, according to the CSR storage format. ! uval - complex(psb_dpk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -289,12 +289,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in laspk. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_ziluk_factint(fill_in,ialg,a,b,& @@ -304,7 +304,7 @@ contains implicit none - ! Arguments + ! Arguments integer(psb_ipk_), intent(in) :: fill_in, ialg type(psb_zspmat_type),intent(in) :: a,b integer(psb_ipk_),intent(inout) :: l1,l2,info @@ -330,14 +330,14 @@ contains select case(ialg) case(psb_ilu_n_,psb_milu_n_) - ! Ok + ! Ok case default info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,& & i_err=(/itwo,ialg,izero,izero,izero/)) goto 9999 end select - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) @@ -349,7 +349,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the iluk_copyin function + ! Allocate a temporary buffer for the iluk_copyin function ! call trw%allocate(izero,izero,ione) @@ -361,7 +361,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -381,34 +381,34 @@ contains uplevs(:) = m+1 row(:) = zzero rowlevs(:) = -(m+1) - + ! ! Cycle over the matrix rows ! do i = 1, m - + ! ! At each iteration of the loop we keep in a heap the column indices ! affected by the factorization. The heap is initialized and filled ! in the iluk_copyin routine, and updated during the elimination, in ! the iluk_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = zzero if (i<=ma) then ! - ! Copy into trw the i-th local row of the matrix, stored in a - ! + ! Copy into trw the i-th local row of the matrix, stored in a + ! call iluk_copyin(i,ma,a,ione,m,row,rowlevs,heap,ktrw,trw,info) else ! ! Copy into trw the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row) - ! + ! (as (i-ma)-th row) + ! call iluk_copyin(i-ma,mb,b,ione,m,row,rowlevs,heap,ktrw,trw,info) endif - + ! Do an elimination step on the current row. It turns out we only ! need to keep track of fill levels for the upper triangle, hence we ! do not have a lowlevs variable. @@ -417,7 +417,7 @@ contains & d,uja,uirp,uval,uplevs,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) if (info /= psb_success_) then @@ -474,11 +474,11 @@ contains ! ! This routine is used by psb_ziluk_factint in the computation of the ! ILU(k)/MILU(k) factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -510,7 +510,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_zspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -521,8 +521,8 @@ contains use psb_base_mod implicit none - - ! Arguments + + ! Arguments type(psb_zspmat_type), intent(in) :: a type(psb_z_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i,m,jmin,jmax @@ -542,17 +542,17 @@ contains if (psb_errstatus_fatal()) then info = psb_err_internal_error_; goto 9999 end if - call heap%init(info) + call heap%init(info) - select type (aa=> a%a) - type is (psb_z_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_z_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! - + do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = aa%val(j) rowlevs(k) = 0 call heap%insert(k,info) @@ -562,14 +562,14 @@ contains class default ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to iluk_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -581,11 +581,11 @@ contains ktrw=1 end if nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw) rowlevs(k) = 0 call heap%insert(k,info) @@ -674,10 +674,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i, fill_in integer(psb_ipk_), intent(inout) :: nidx,info integer(psb_ipk_), intent(inout) :: rowlevs(:) @@ -690,7 +690,7 @@ contains complex(psb_dpk_) :: rwk info = psb_success_ - if (.not.allocated(idxs)) then + if (.not.allocated(idxs)) then allocate(idxs(200),stat=info) if (info /= psb_success_) return endif @@ -702,34 +702,34 @@ contains ! do ! Beware: (iret < 0) means that the heap is empty, not an error. - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) return - ! + ! ! Just in case an index has been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k nidx = nidx + 1 - if (nidx>size(idxs)) then + if (nidx>size(idxs)) then call psb_realloc(nidx+psb_heap_resize,idxs,info) if (info /= psb_success_) return end if idxs(nidx) = k - - if ((row(k) /= zzero).and.(rowlevs(k) <= fill_in).and.(ki) then + else if (j>i) then ! ! Copy the upper part of the row - ! - if (rowlevs(j) <= fill_in) then - l2 = l2 + 1 - if (size(uval) < l2) then - ! + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uval) < l2) then + ! ! Figure out a good reallocation size! ! isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uval,info) - if (info == psb_success_) call psb_realloc(isz,uja,info) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -941,11 +941,11 @@ contains end if uja(l2) = j uval(l2) = row(j) - uplevs(l2) = rowlevs(j) + uplevs(l2) = rowlevs(j) else if (ialg == psb_milu_n_) then ! ! MILU(k): add discarded entries to the diagonal one - ! + ! d(i) = d(i) + row(j) end if ! @@ -963,13 +963,13 @@ contains lirp(i+1) = l1 + 1 uirp(i+1) = l2 + 1 - ! + ! ! Check the pivot size ! if (abs(d(i)) < d_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) diff --git a/prec/impl/psb_z_ilut_fact.f90 b/prec/impl/psb_z_ilut_fact.f90 index b7e8da05..291dc778 100644 --- a/prec/impl/psb_z_ilut_fact.f90 +++ b/prec/impl/psb_z_ilut_fact.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,21 +27,21 @@ ! 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. -! +! ! Moved here from MLD2P4, original copyright below. -! -! -! +! +! +! ! MLD2P4 version 2.2 ! MultiLevel Domain Decomposition Parallel Preconditioners Package ! based on PSBLAS (Parallel Sparse BLAS version 3.5) -! -! (C) Copyright 2008-2018 -! -! Salvatore Filippone -! Pasqua D'Ambra -! Daniela di Serafino -! +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -53,7 +53,7 @@ ! 3. The name of the MLD2P4 group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -65,8 +65,8 @@ ! 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. -! -! +! +! ! File: psb_zilut_fact.f90 ! ! Subroutine: psb_zilut_fact @@ -87,7 +87,7 @@ ! CSR. The diagonal of the U factor is stored separately (actually, the ! inverse of the diagonal entries is stored; this is then managed in the ! solve stage associated to the ILU(k,t) factorization). -! +! ! ! Arguments: ! fill_in - integer, input. @@ -114,7 +114,7 @@ ! factorization. ! Note: its allocation is managed by the calling routine psb_ilu_bld, ! hence it cannot be only intent(out). -! info - integer, output. +! info - integer, output. ! Error code. ! blck - type(psb_zspmat_type), input, optional, target. ! The sparse matrix structure containing the remote rows of the @@ -122,9 +122,9 @@ ! to build an Additive Schwarz base preconditioner with overlap ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see psb_fact_bld), then blck does not contain any row. -! +! subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) - + use psb_base_mod use psb_z_ilu_fact_mod, psb_protect_name => psb_zilut_fact @@ -141,7 +141,7 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) integer(psb_ipk_), intent(in), optional :: iscale ! Local Variables integer(psb_ipk_) :: l1, l2, m, err_act, iscale_ - + type(psb_zspmat_type), pointer :: blck_ type(psb_z_csr_sparse_mat) :: ll, uu real(psb_dpk_) :: scale @@ -151,34 +151,34 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) info = psb_success_ call psb_erractionsave(err_act) - if (fill_in < 0) then + if (fill_in < 0) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name, & & i_err=(/ione,fill_in,izero,izero,izero/)) goto 9999 end if - ! + ! ! Point to / allocate memory for the incomplete factorization ! - if (present(blck)) then + if (present(blck)) then blck_ => blck else - allocate(blck_,stat=info) - if (info == psb_success_) call blck_%csall(izero,izero,info,ione) + allocate(blck_,stat=info) + if (info == psb_success_) call blck_%allocate(izero,izero,info,ione,type='CSR') if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='csall' + ch_err='allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if endif - if (present(iscale)) then + if (present(iscale)) then iscale_ = iscale else iscale_ = psb_ilu_scale_none_ end if - - select case(iscale_) + + select case(iscale_) case(psb_ilu_scale_none_) scale = sone case(psb_ilu_scale_maxval_) @@ -189,10 +189,10 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call psb_errpush(info,name,i_err=(/ione*9,iscale_,izero,izero,izero/)) goto 9999 end select - + m = a%get_nrows() + blck_%get_nrows() if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& - & (m > size(d)) ) then + & (m > size(d)) ) then write(0,*) 'Wrong allocation status for L,D,U? ',& & l%get_nrows(),size(d),u%get_nrows() info = -1 @@ -225,15 +225,15 @@ subroutine psb_zilut_fact(fill_in,thres,a,l,u,d,info,blck,iscale) call u%set_triangle() call u%set_unit() call u%set_upper() - + ! ! Nullify pointer / deallocate memory ! - if (present(blck)) then - blck_ => null() + if (present(blck)) then + blck_ => null() else call blck_%free() - deallocate(blck_,stat=info) + deallocate(blck_,stat=info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -298,7 +298,7 @@ contains ! according to the CSR storage format. ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in lval, according to the CSR storage format. + ! of the L factor in lval, according to the CSR storage format. ! uval - complex(psb_dpk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. @@ -307,12 +307,12 @@ contains ! according to the CSR storage format. ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uval, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in lval. ! l2 - integer, output ! The number of nonzero entries in uval. - ! info - integer, output. + ! info - integer, output. ! Error code. ! subroutine psb_zilut_factint(fill_in,thres,a,b,& @@ -320,7 +320,7 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments integer(psb_ipk_), intent(in) :: fill_in @@ -355,7 +355,7 @@ contains m = ma+mb ! - ! Allocate a temporary buffer for the ilut_copyin function + ! Allocate a temporary buffer for the ilut_copyin function ! call trw%allocate(izero,izero,ione) if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) @@ -366,7 +366,7 @@ contains call psb_errpush(info,name,a_err='psb_sp_all') goto 9999 end if - + l1=0 l2=0 lirp(1) = 1 @@ -396,10 +396,10 @@ contains ! in the ilut_copyin function, and updated during the elimination, in ! the ilut_fact routine. The heap is ideal because at each step we need ! the lowest index, but we also need to insert new items, and the heap - ! allows to do both in log time. + ! allows to do both in log time. ! d(i) = czero - if (i<=ma) then + if (i<=ma) then call ilut_copyin(i,ma,a,i,ione,m,nlw,nup,jmaxup,nrmi,weight,& & row,heap,ktrw,trw,info) else @@ -414,7 +414,7 @@ contains & d,uja,uirp,uval,nidx,idxs,info) ! ! Copy the row into lval/d(i)/uval - ! + ! if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,& & nlw,nup,jmaxup,nrmi,row,nidx,idxs,& & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) @@ -429,7 +429,7 @@ contains ! ! Adjust diagonal accounting for scale factor ! - if (weight /= sone) then + if (weight /= sone) then d(1:m) = d(1:m)*weight end if @@ -469,7 +469,7 @@ contains ! - storing into a heap the column indices of the nonzero entries of the copied ! row; ! - computing the column index of the first entry with maximum absolute value - ! in the part of the row belonging to the upper triangle; + ! in the part of the row belonging to the upper triangle; ! - computing the 2-norm of the row. ! The output array row is such that it contains a full row of A, i.e. it contains ! also the zero entries of the row. This is useful for the elimination step @@ -482,11 +482,11 @@ contains ! ! This routine is used by psb_zilut_factint in the computation of the ILU(k,t) ! factorization of a local sparse matrix. - ! + ! ! ! Arguments: ! i - integer, input. - ! The local index of the row to be extracted from the + ! The local index of the row to be extracted from the ! sparse matrix structure a. ! m - integer, input. ! The number of rows of the local matrix stored into a. @@ -533,7 +533,7 @@ contains ! staging buffer trw. See below. ! trw - type(psb_zspmat_type), input/output. ! A staging buffer. If the matrix A is not in CSR format, we use - ! the psb_sp_getblk routine and store its output in trw; when we + ! the psb_sp_getblk routine and store its output in trw; when we ! need to call psb_sp_getblk we do it for a block of rows, and then ! we consume them from trw in successive calls to this routine, ! until we empty the buffer. Thus we will make a call to psb_sp_getblk @@ -542,7 +542,7 @@ contains subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,& & nrmi,weight,row,heap,ktrw,trw,info) use psb_base_mod - implicit none + implicit none type(psb_zspmat_type), intent(in) :: a type(psb_z_coo_sparse_mat), intent(inout) :: trw integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd @@ -584,29 +584,29 @@ contains dmaxup = szero nrmi = szero - select type (aa=> a%a) - type is (psb_z_csr_sparse_mat) + select type (aa=> a%a) + type is (psb_z_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! do j = aa%irp(i), aa%irp(i+1) - 1 k = aa%ja(j) - if ((jmin<=k).and.(k<=jmax)) then - row(k) = aa%val(j)*weight + if ((jmin<=k).and.(k<=jmax)) then + row(k) = aa%val(j)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if end if end if end do - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 @@ -617,16 +617,16 @@ contains class default - + ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! Otherwise use psb_sp_getblk, slower but able (in principle) of ! handling any format. In this case, a block of rows is extracted ! instead of a single row, for performance reasons, and these ! rows are copied one by one into the array row, through successive ! calls to ilut_copyin. ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then @@ -639,18 +639,18 @@ contains kin = ktrw nz = trw%get_nzeros() - do + do if (ktrw > nz) exit if (trw%ia(ktrw) > i) exit k = trw%ja(ktrw) - if ((jmin<=k).and.(k<=jmax)) then + if ((jmin<=k).and.(k<=jmax)) then row(k) = trw%val(ktrw)*weight call heap%insert(k,info) if (info /= psb_success_) exit - if (kjd) then + if (kjd) then nup = nup + 1 - if (abs(row(k))>dmaxup) then + if (abs(row(k))>dmaxup) then jmaxup = k dmaxup = abs(row(k)) end if @@ -734,10 +734,10 @@ contains use psb_base_mod - implicit none + implicit none ! Arguments - type(psb_i_heap), intent(inout) :: heap + type(psb_i_heap), intent(inout) :: heap integer(psb_ipk_), intent(in) :: i integer(psb_ipk_), intent(inout) :: nidx,info real(psb_dpk_), intent(in) :: thres,nrmi @@ -753,23 +753,23 @@ contains call psb_ensure_size(200*ione,idxs,info) if (info /= psb_success_) return nidx = 0 - lastk = -1 + lastk = -1 ! ! Do while there are indices to be processed ! do - call heap%get_first(k,iret) + call heap%get_first(k,iret) if (iret < 0) exit - ! + ! ! An index may have been put on the heap more than once. ! if (k == lastk) cycle - lastk = k + lastk = k lowert: if (k nidx) exit if (idxs(idxp) >= i) exit @@ -987,8 +987,8 @@ contains ! if (abs(witem) < thres*nrmi) cycle - nz = nz + 1 - xw(nz) = witem + nz = nz + 1 + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1000,9 +1000,9 @@ contains ! ! Now we have to take out the first nlw+fill_in entries - ! + ! if (nz <= nlw+fill_in) then - ! + ! ! Just copy everything from xw, and it is already ordered ! else @@ -1014,7 +1014,7 @@ contains call psb_errpush(info,name,a_err='psb_heap_get_first') goto 9999 end if - + xw(k) = witem xwid(k) = widx end do @@ -1029,15 +1029,15 @@ contains ! Copy out the lower part of the row ! do k=1,nz - l1 = l1 + 1 + l1 = l1 + 1 if (size(lval) < l1) then - ! + ! ! Figure out a good reallocation size! - ! + ! isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,lval,info) - if (info == psb_success_) call psb_realloc(isz,lja,info) - if (info /= psb_success_) then + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 @@ -1046,25 +1046,25 @@ contains lja(l1) = xwid(k) lval(l1) = xw(indx(k)) end do - + ! ! Make sure idxp points to the diagonal entry ! - if (idxp <= size(idxs)) then - if (idxs(idxp) < i) then - do + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do idxp = idxp + 1 if (idxp > nidx) exit if (idxs(idxp) >= i) exit end do end if end if - if (idxp > size(idxs)) then + if (idxp > size(idxs)) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' else - if (idxs(idxp) > i) then + if (idxs(idxp) > i) then !!$ write(0,*) 'Warning: missing diagonal element in the row ' - else if (idxs(idxp) /= i) then + else if (idxs(idxp) /= i) then !!$ write(0,*) 'Warning: impossible error: diagonal has vanished' else ! @@ -1076,7 +1076,7 @@ contains if (abs(d(i)) < d_epstol) then ! ! Too small pivot: unstable factorization - ! + ! info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') d(i) @@ -1092,7 +1092,7 @@ contains end if ! - ! Now the upper part + ! Now the upper part ! call heap%init(info,dir=psb_asort_down_) @@ -1104,15 +1104,15 @@ contains nz = 0 do - + idxp = idxp + 1 if (idxp > nidx) exit widx = idxs(idxp) - if (widx <= i) then + if (widx <= i) then !!$ write(0,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) cycle end if - if (widx > m) then + if (widx > m) then !!$ write(0,*) 'Warning: impossible value',widx,i,idxp,idxs(idxp) cycle end if @@ -1120,12 +1120,12 @@ contains ! ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. ! - if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then - cycle + if ((widx /= jmaxup) .and. (abs(witem) < thres*nrmi)) then + cycle end if nz = nz + 1 - xw(nz) = witem + xw(nz) = witem xwid(nz) = widx call heap%insert(witem,widx,info) if (info /= psb_success_) then @@ -1133,7 +1133,7 @@ contains call psb_errpush(info,name,a_err='psb_insert_heap') goto 9999 end if - + end do ! @@ -1141,7 +1141,7 @@ contains ! we include entry jmaxup. ! if (nz <= nup+fill_in) then - ! + ! ! Just copy everything from xw ! fndmaxup=.true. @@ -1155,13 +1155,13 @@ contains if (widx == jmaxup) fndmaxup=.true. end do end if - if ((i psb_z_invk_bld + use psb_z_ilu_fact_mod + implicit none + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_zspmat_type), intent(inout) :: lmat, umat + complex(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_zspmat_type) :: atmp + complex(psb_dpk_), allocatable :: pq(:), pd(:) + integer(psb_ipk_), allocatable :: uplevs(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + character(len=20) :: name, ch_err + + + info = psb_success_ + name='psb_zinvk_bld' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + + call psb_iluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + !,uplevs=uplevs) + !call psb_ziluk_fact(fill1,psb_ilu_n_,a,lmat,umat,pd,info,blck=blck) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + ! + ! Compute the aprox U^-1 and L^-1 + ! + call psb_sparse_invk(n_row,umat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_sparse_invk(n_row,lmat,atmp,fill2,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_invk_bld + +subroutine psb_zsparse_invk(n,a,z,fill_in,info,inlevs) + + use psb_base_mod + use psb_z_invk_fact_mod, psb_protect_name => psb_zsparse_invk + + integer(psb_ipk_), intent(in) :: n + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:), jz(:) + complex(psb_dpk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:), idxs(:) + complex(psb_dpk_), allocatable :: row(:) + type(psb_z_coo_sparse_mat) :: trw + type(psb_z_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx + type(psb_i_heap) :: heap + + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_sp_invk' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + allocate(uplevs(acsr%get_nzeros()),stat=info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + uplevs(:) = 0 + row(:) = zzero + rowlevs(:) = -(n+1) + + call zcsr%allocate(n,n,n*fill_in) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + call psb_ensure_size(n+1, idxs, info) + + + ! + ! + zcsr%irp(1) = 1 + nzz = 0 + + l2 = 0 + outer: do i = 1, n-1 + ! ZW = e_i + call psb_invk_copyin(i,n,acsr,ione,n,row,rowlevs,heap,ktrw,trw,info,& + & sign=-done,inlevs=inlevs) + row(i) = zone + rowlevs(i) = 0 + + ! Update loop + call psb_invk_inv(fill_in,i,row,rowlevs,heap,& + & acsr%ja,acsr%irp,acsr%val,uplevs,nidx,idxs,info) + + call psb_invk_copyout(fill_in,i,n,row,rowlevs,nidx,idxs,& + & l2,zcsr%ja,zcsr%irp,zcsr%val,info) + + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = zone + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + call zcsr%set_sorted() + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_zsparse_invk + +subroutine psb_z_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,ktrw,trw,info,sign,inlevs) + + use psb_base_mod + use psb_z_invk_fact_mod, psb_protect_name => psb_z_invk_copyin + + implicit none + + ! Arguments + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + complex(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + + ! Local variables + integer(psb_ipk_) :: k,j,irb,err_act, nz + integer(psb_ipk_), parameter :: nrb=16 + real(psb_dpk_) :: sign_ + character(len=20), parameter :: name='invk_copyin' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + + if (present(sign)) then + sign_ = sign + else + sign_ = done + end if + + + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! + if (present(inlevs)) then + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = inlevs(j) + call heap%insert(k,info) + end if + end do + else + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + rowlevs(k) = 0 + call heap%insert(k,info) + end if + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_invk_copyin + + +subroutine psb_z_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + + use psb_base_mod + use psb_z_invk_fact_mod, psb_protect_name => psb_z_invk_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + complex(psb_dpk_), allocatable, intent(inout) :: uaspk(:) + complex(psb_dpk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: j,isz,err_act,int_err(5),idxp + character(len=20), parameter :: name='psb_ziluk_factint' + character(len=20) :: ch_err + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + do idxp=1,nidx + + j = idxs(idxp) + + if (j>=i) then + ! + ! Copy the upper part of the row + ! + if (rowlevs(j) <= fill_in) then + l2 = l2 + 1 + if (size(uaspk) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,uaspk,info) + if (info == psb_success_) call psb_realloc(isz,uia1,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + uia1(l2) = j + uaspk(l2) = row(j) + end if + ! + ! Re-initialize row(j) and rowlevs(j) + ! + row(j) = zzero + rowlevs(j) = -(m+1) + end if + end do + + uia2(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_invk_copyout + +subroutine psb_zinvk_inv(fill_in,i,row,rowlevs,heap,ja,irp,val,uplevs,& + & nidx,idxs,info) + + use psb_base_mod + use psb_z_invk_fact_mod, psb_protect_name => psb_zinvk_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:),uplevs(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_), intent(inout) :: row(:) + + ! Local variables + integer(psb_ipk_) :: k,j,lrwk,jj,lastk, iret + real(psb_dpk_) :: rwk + + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + + ! + ! Do while there are indices to be processed + ! + do + ! Beware: (iret < 0) means that the heap is empty, not an error. + call heap%get_first(k,iret) + if (iret < 0) then +!!$ write(psb_err_unit,*) 'IINVK: ',i,' returning at ',lastk + return + end if + + ! + ! Just in case an index has been put on the heap more than once. + ! + if (k == lastk) cycle + + lastk = k + nidx = nidx + 1 + if (nidx>size(idxs)) then + call psb_realloc(nidx+psb_heap_resize,idxs,info) + if (info /= psb_success_) return + end if + idxs(nidx) = k + + if ((row(k) /= zzero).and.(rowlevs(k) <= fill_in)) then + ! + ! Note: since U is scaled while copying it out (see iluk_copyout), + ! we can use rwk in the update below + ! + rwk = row(k) + lrwk = rowlevs(k) + + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Insert the index into the heap for further processing. + ! The fill levels are initialized to a negative value. If we find + ! one, it means that it is an as yet untouched index, so we need + ! to insert it; otherwise it is already on the heap, there is no + ! need to insert it more than once. + ! + if (rowlevs(j)<0) then + call heap%insert(j,info) + if (info /= psb_success_) return + rowlevs(j) = abs(rowlevs(j)) + end if + ! + ! Update row(j) and the corresponding fill level + ! + row(j) = row(j) - rwk * val(jj) + rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1) + end do + + end if + end do + +end subroutine psb_zinvk_inv diff --git a/prec/impl/psb_z_invt_fact.f90 b/prec/impl/psb_z_invt_fact.f90 new file mode 100644 index 00000000..bed713ae --- /dev/null +++ b/prec/impl/psb_z_invt_fact.f90 @@ -0,0 +1,739 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! + +subroutine psb_z_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + + use psb_base_mod + use psb_z_invt_fact_mod, psb_protect_name => psb_z_invt_bld + use psb_z_ilu_fact_mod + implicit none + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_dpk_), intent(in) :: thresh + real(psb_dpk_), intent(in) :: invthresh + type(psb_zspmat_type), intent(inout) :: lmat, umat + complex(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), optional :: blck + ! + integer(psb_ipk_) :: i, nztota, err_act, n_row, nrow_a, n_col + type(psb_zspmat_type) :: atmp + complex(psb_dpk_), allocatable :: pq(:), pd(:), w(:) + integer(psb_ipk_) :: debug_level, debug_unit + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me + integer(psb_ipk_) :: nzrmax + real(psb_dpk_) :: sp_thresh + character(len=20) :: name, ch_err, fname + + + info = psb_success_ + name='psb_zinvt_fact' + 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() + ctxt = psb_cd_get_context(desc) + call psb_info(ctxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + ! + ! Check the memory available to hold the incomplete L and U factors + ! and allocate it if needed + ! + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + + if (present(blck)) then + nztota = nztota + blck%get_nzeros() + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ': out get_nnzeros',nrow_a,nztota,& + & a%get_nrows(),a%get_ncols(),a%get_nzeros() + + + n_row = psb_cd_get_local_rows(desc) + n_col = psb_cd_get_local_cols(desc) + allocate(pd(n_row),w(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + nzrmax = fillin + sp_thresh = thresh + + call lmat%allocate(n_row,n_row,info,nz=nztota) + if (info == psb_success_) call umat%allocate(n_row,n_row,info,nz=nztota) + + if (info == 0) call psb_ilut_fact(nzrmax,sp_thresh,& + & a,lmat,umat,pd,info,blck=blck,iscale=psb_ilu_scale_maxval_) + + if (info == psb_success_) call atmp%allocate(n_row,n_row,info,nz=nztota) + if(info/=0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (.false.) then +!!$ if (debug_level >= psb_debug_inner_) then + write(fname,'(a,i0,a)') 'invt-lo-',me,'.mtx' + call lmat%print(fname,head="INVTLOW") + write(fname,'(a,i0,a)') 'invt-up-',me,'.mtx' + call umat%print(fname,head="INVTUPP") + end if + + ! + ! Compute the approx U^-1 and L^-1 + ! + nzrmax = invfill + call psb_zsparse_invt(n_row,umat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,umat,info) + if (info == psb_success_) call lmat%transp() + if (info == psb_success_) call psb_zsparse_invt(n_row,lmat,atmp,nzrmax,invthresh,info) + if (info == psb_success_) call psb_move_alloc(atmp,lmat,info) + if (info == psb_success_) call lmat%transp() + ! Done. Hopefully.... + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invt') + goto 9999 + end if + + call psb_move_alloc(pd,d,info) + call lmat%set_asb() + call lmat%trim() + call umat%set_asb() + call umat%trim() + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_invt_bld + +subroutine psb_zsparse_invt(n,a,z,nzrmax,sp_thresh,info) + + use psb_base_mod + use psb_z_invt_fact_mod, psb_protect_name => psb_zsparse_invt + + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i,j,k, err_act, nz, nzra, nzrz, ipz1,ipz2, nzz, ip1, ip2, l2 + integer(psb_ipk_), allocatable :: ia(:), ja(:), iz(:),jz(:) + complex(psb_dpk_), allocatable :: zw(:), val(:), valz(:) + integer(psb_ipk_), allocatable :: uplevs(:), rowlevs(:),idxs(:) + complex(psb_dpk_), allocatable :: row(:) + type(psb_z_coo_sparse_mat) :: trw + type(psb_z_csr_sparse_mat) :: acsr, zcsr + integer(psb_ipk_) :: ktrw, nidx, nlw,nup,jmaxup + type(psb_i_heap) :: heap + real(psb_dpk_) :: alpha, nrmi + character(len=20) :: name='psb_sp_invt' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (.not.(a%is_triangle().and.a%is_unit().and.a%is_upper())) then + write(psb_err_unit,*) 'Wrong A ' + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='wrong A') + goto 9999 + end if + call a%cp_to(acsr) + call trw%allocate(izero,izero,ione) + if (info == psb_success_) allocate(zw(n),iz(n),valz(n),& + & row(n),rowlevs(n),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + call zcsr%allocate(n,n,n*nzrmax) + call zcsr%set_triangle() + call zcsr%set_unit(.false.) + call zcsr%set_upper() + ! + ! + nzz = 0 + row(:) = zzero + rowlevs(:) = 0 + l2 = 0 + zcsr%irp(1) = 1 + + outer: do i = 1, n-1 + ! ZW = e_i + call psb_z_invt_copyin(i,n,acsr,i,ione,n,nlw,nup,jmaxup,nrmi,row,& + & heap,rowlevs,ktrw,trw,info,sign=-done) + if (info /= 0) exit + row(i) = zone + ! Adjust norm + if (nrmi < done) then + nrmi = sqrt(done + nrmi**2) + else + nrmi = nrmi*sqrt(zone+zone/(nrmi**2)) + end if + + call psb_invt_inv(sp_thresh,i,nrmi,row,heap,rowlevs,& + & acsr%ja,acsr%irp,acsr%val,nidx,idxs,info) + if (info /= 0) exit +!!$ write(0,*) 'Calling copyout ',nzrmax,nlw,nup,nidx,l2 + call psb_z_invt_copyout(nzrmax,sp_thresh,i,n,nlw,nup,jmaxup,nrmi,row,& + & nidx,idxs,l2,zcsr%ja,zcsr%irp,zcsr%val,info) + if (info /= 0) exit + nzz = l2 + end do outer + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='mainloop') + goto 9999 + end if + + ipz1 = nzz+1 + call psb_ensure_size(ipz1,zcsr%val,info) + call psb_ensure_size(ipz1,zcsr%ja,info) + zcsr%val(ipz1) = zone + zcsr%ja(ipz1) = n + zcsr%irp(n+1) = ipz1+1 + + call z%mv_from(zcsr) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_zsparse_invt + +subroutine psb_z_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + use psb_base_mod + use psb_d_invt_fact_mod, psb_protect_name => psb_d_invt_copyin + implicit none + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(inout) :: nrmi + complex(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), intent(in), optional :: sign + ! + integer(psb_ipk_) :: k,j,irb,kin,nz, err_act + integer(psb_ipk_), parameter :: nrb=16 + real(psb_dpk_) :: dmaxup, sign_ + real(psb_dpk_), external :: dnrm2 + character(len=20), parameter :: name='invt_copyin' + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + call heap%init(info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + goto 9999 + end if + sign_ = done + if (present(sign)) sign_ = sign + ! + ! nrmi is the norm of the current sparse row (for the time being, + ! we use the 2-norm). + ! NOTE: the 2-norm below includes also elements that are outside + ! [jmin:jmax] strictly. Is this really important? TO BE CHECKED. + ! + + nlw = 0 + nup = 0 + jmaxup = 0 + dmaxup = zzero + nrmi = zzero + + do j = a%irp(i), a%irp(i+1) - 1 + k = a%ja(j) + if ((jmin<=k).and.(k<=jmax)) then + row(k) = sign_ * a%val(j) + call heap%insert(k,info) + irwt(k) = 1 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end if + if (kjd) then + nup = nup + 1 + if (abs(row(k))>dmaxup) then + jmaxup = k + dmaxup = abs(row(k)) + end if + end if + end do + nz = a%irp(i+1) - a%irp(i) + nrmi = dnrm2(nz,a%val(a%irp(i):),ione) + + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_invt_copyin + +subroutine psb_z_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + + use psb_base_mod + use psb_z_invt_fact_mod, psb_protect_name => psb_z_invt_copyout + + implicit none + + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_dpk_), intent(in) :: thres,nrmi + complex(psb_dpk_),allocatable, intent(inout) :: val(:) + complex(psb_dpk_), intent(inout) :: row(:) + + ! Local variables + real(psb_dpk_),allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + real(psb_dpk_) :: witem, wmin + integer(psb_ipk_) :: widx + integer(psb_ipk_) :: k,isz,err_act,int_err(5),idxp, nz + type(psb_d_idx_heap) :: heap + character(len=20), parameter :: name='invt_copyout' + character(len=20) :: ch_err + logical :: fndmaxup + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + ! + ! Here we need to apply also the dropping rule base on the fill-in. + ! We do it by putting into a heap the elements that are not dropped + ! by using the 2-norm rule, and then copying them out. + ! + ! The heap goes down on the entry absolute value, so the first item + ! is the largest absolute value. + ! +!!$ write(0,*) 'invt_copyout ',nidx,nup+fill_in + call heap%init(info,dir=psb_asort_down_) + + if (info == psb_success_) allocate(xwid(nidx),xw(nidx),indx(nidx),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/3*nidx/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + ! + ! First the lower part + ! + + nz = 0 + idxp = 0 + + do + + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + widx = idxs(idxp) + witem = row(widx) + ! + ! Dropping rule based on the 2-norm + ! + if (abs(witem) < thres*nrmi) cycle + + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + end do + + if (nz > 1) then + write(psb_err_unit,*) 'Warning: lower triangle from invt???? ' + end if + + + if (idxp <= size(idxs)) then + if (idxs(idxp) < i) then + do + idxp = idxp + 1 + if (idxp > nidx) exit + if (idxs(idxp) >= i) exit + end do + end if + end if + idxp = idxp - 1 + nz = 0 + wmin=HUGE(wmin) + if (.false.) then + do + + idxp = idxp + 1 + if (idxp > nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= jmaxup) .and. (widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if ((widx/=jmaxup).and.(nz > nup+fill_in)) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz <= nup+fill_in) then + ! + ! Just copy everything from xw + ! + fndmaxup=.true. + else + fndmaxup = .false. + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + if (widx == jmaxup) fndmaxup=.true. + end do + end if + if ((i nidx) exit + widx = idxs(idxp) + if (widx < i) then + write(psb_err_unit,*) 'Warning: lower triangle in upper copy',widx,i,idxp,idxs(idxp) + cycle + end if + if (widx > m) then + cycle + end if + witem = row(widx) + ! + ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. + ! + if ((widx /= i) .and. (abs(witem) < thres*nrmi)) then + cycle + end if + if (nz > nup+fill_in) then + if (abs(witem) < wmin) cycle + endif + wmin = min(abs(witem),wmin) + nz = nz + 1 + xw(nz) = witem + xwid(nz) = widx + call heap%insert(witem,widx,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + end do + + ! + ! Now we have to take out the first nup-fill_in entries. But make sure + ! we include entry jmaxup. + ! + if (nz > nup+fill_in) then + nz = nup+fill_in + do k=1,nz + call heap%get_first(witem,widx,info) + xw(k) = witem + xwid(k) = widx + end do + end if + end if + + ! + ! Now we put things back into ascending column order + ! + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) + + ! + ! Copy out the upper part of the row + ! + do k=1,nz + l2 = l2 + 1 + if (size(val) < l2) then + ! + ! Figure out a good reallocation size! + ! + isz = max(int(1.2*l2),l2+100) + call psb_realloc(isz,val,info) + if (info == psb_success_) call psb_realloc(isz,ja,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + end if + ja(l2) = xwid(k) + val(l2) = xw(indx(k)) + end do + + ! + ! Set row to zero + ! + do idxp=1,nidx + row(idxs(idxp)) = zzero + end do + + irp(i+1) = l2 + 1 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return +end subroutine psb_z_invt_copyout + +subroutine psb_z_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val,nidx,idxs,info) + + use psb_base_mod + use psb_z_invt_fact_mod, psb_protect_name => psb_z_invt_inv + + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_), intent(inout) :: row(:) + + ! Local Variables + integer(psb_ipk_) :: k,j,jj,lastk,iret + real(psb_dpk_) :: rwk, alpha + + info = psb_success_ + + call psb_ensure_size(200, idxs, info) + if (info /= psb_success_) return + nidx = 1 + idxs(1) = i + lastk = i + irwt(i) = 1 +!!$ write(0,*) 'Drop Threshold ',thres*nrmi + ! + ! Do while there are indices to be processed + ! + do + + call heap%get_first(k,iret) + if (iret < 0) exit + + ! + ! An index may have been put on the heap more than once. + ! Should not happen, but just in case. + ! + if (k == lastk) cycle + lastk = k + + ! + ! Dropping rule based on the threshold: compare the absolute + ! value of each updated entry of row with thres * 2-norm of row. + ! + rwk = row(k) + + if (abs(rwk) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(k) = dzero + irwt(k) = 0 + cycle + else + ! + ! Note: since U is scaled while copying it out (see ilut_copyout), + ! we can use rwk in the update below. + ! + do jj=irp(k),irp(k+1)-1 + j = ja(jj) + if (j<=k) then + info = -i + return + endif + ! + ! Update row(j) and, if it is not to be discarded, insert + ! its index into the heap for further processing. + ! + row(j) = row(j) - rwk * val(jj) + if (irwt(j) == 0) then + if (abs(row(j)) < thres*nrmi) then + ! + ! Drop the entry. + ! + row(j) = dzero + else + ! + ! Do the insertion. + ! + call heap%insert(j,info) + if (info /= psb_success_) return + irwt(j) = 1 + end if + end if + end do + end if + + ! + ! If we get here it is an index we need to keep on copyout. + ! + + nidx = nidx + 1 + call psb_ensure_size(nidx,idxs,info,addsz=psb_heap_resize) + if (info /= psb_success_) return + idxs(nidx) = k + irwt(k) = 0 + end do + + irwt(i) = 0 +end subroutine psb_z_invt_inv diff --git a/prec/impl/psb_z_prec_type_impl.f90 b/prec/impl/psb_z_prec_type_impl.f90 index 982fc008..00f0b05e 100644 --- a/prec/impl/psb_z_prec_type_impl.f90 +++ b/prec/impl/psb_z_prec_type_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,14 +27,14 @@ ! 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. -! -! -! +! +! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -46,7 +46,7 @@ !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific 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 @@ -58,14 +58,14 @@ !!$ 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. -!!$ -!!$ +!!$ +!!$ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine psb_z_apply2_vect(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_z_prec_type, psb_protect_name => psb_z_apply2_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_zprec_type), intent(inout) :: prec type(psb_z_vect_type),intent(inout) :: x @@ -74,9 +74,10 @@ subroutine psb_z_apply2_vect(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans complex(psb_dpk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ complex(psb_dpk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -84,28 +85,28 @@ subroutine psb_z_apply2_vect(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -114,13 +115,13 @@ subroutine psb_z_apply2_vect(prec,x,y,desc_data,info,trans,work) call prec%prec%apply(zone,x,zzero,y,desc_data,info,& & trans=trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -135,7 +136,7 @@ end subroutine psb_z_apply2_vect subroutine psb_z_apply1_vect(prec,x,desc_data,info,trans,work) use psb_base_mod use psb_z_prec_type, psb_protect_name => psb_z_apply1_vect - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_zprec_type), intent(inout) :: prec type(psb_z_vect_type),intent(inout) :: x @@ -144,9 +145,10 @@ subroutine psb_z_apply1_vect(prec,x,desc_data,info,trans,work) complex(psb_dpk_),intent(inout), optional, target :: work(:) type(psb_z_vect_type) :: ww - character :: trans_ + character :: trans_ complex(psb_dpk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -154,28 +156,28 @@ subroutine psb_z_apply1_vect(prec,x,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 @@ -186,13 +188,13 @@ subroutine psb_z_apply1_vect(prec,x,desc_data,info,trans,work) & trans=trans_,work=work_) if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info) call psb_gefree(ww,desc_data,info) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -207,7 +209,7 @@ end subroutine psb_z_apply1_vect subroutine psb_z_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod use psb_z_prec_type, psb_protect_name => psb_z_apply2v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_zprec_type), intent(inout) :: prec complex(psb_dpk_),intent(inout) :: x(:) @@ -216,9 +218,10 @@ subroutine psb_z_apply2v(prec,x,y,desc_data,info,trans,work) character(len=1), optional :: trans complex(psb_dpk_),intent(inout), optional, target :: work(:) - character :: trans_ + character :: trans_ complex(psb_dpk_), pointer :: work_(:) - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act character(len=20) :: name @@ -226,40 +229,40 @@ subroutine psb_z_apply2v(prec,x,y,desc_data,info,trans,work) info = psb_success_ call psb_erractionsave(err_act) - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) - if (present(trans)) then + if (present(trans)) then trans_=trans else trans_='N' end if - if (present(work)) then + if (present(work)) then work_ => work else allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if call prec%prec%apply(zone,x,zzero,y,desc_data,info,trans_,work=work_) - if (present(work)) then + if (present(work)) then else deallocate(work_,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if end if @@ -274,7 +277,7 @@ end subroutine psb_z_apply2v subroutine psb_z_apply1v(prec,x,desc_data,info,trans) use psb_base_mod use psb_z_prec_type, psb_protect_name => psb_z_apply1v - implicit none + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_zprec_type), intent(inout) :: prec complex(psb_dpk_),intent(inout) :: x(:) @@ -282,43 +285,42 @@ subroutine psb_z_apply1v(prec,x,desc_data,info,trans) character(len=1), optional :: trans character :: trans_ - integer(psb_ipk_) :: ictxt,np,me + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np,me integer(psb_ipk_) :: err_act complex(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_z_apply1v' info = psb_success_ call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + if (present(trans)) then trans_=psb_toupper(trans) else trans_='N' end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') - goto 9999 + goto 9999 end if call prec%prec%apply(zone,x,zzero,ww,desc_data,info,& & trans_,work=w1) if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 + goto 9999 end if @@ -332,3 +334,159 @@ subroutine psb_z_apply1v(prec,x,desc_data,info,trans) end subroutine psb_z_apply1v +subroutine psb_zcprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_z_prec_type, psb_protect_name => psb_zcprecseti + implicit none + + class(psb_zprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precseti' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_FILLIN') + call prec%prec%precset(psb_ilu_fill_in_,val,info) + case ('INV_FILLIN') + call prec%prec%precset(psb_inv_fillin_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_zcprecseti + +subroutine psb_zcprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_z_prec_type, psb_protect_name => psb_zcprecsetr + implicit none + + class(psb_zprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetr' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case('SUB_ILUTHRS') + call prec%prec%precset(psb_fact_eps_,val,info) + case('INV_THRESH') + call prec%prec%precset(psb_inv_thresh_,val,info) + case default + info = psb_err_invalid_args_combination_ + write(psb_err_unit,*) name,& + & ': Error: uninitialized preconditioner,',& + &' should call prec%init' + return + end select + +end subroutine psb_zcprecsetr + +subroutine psb_zcprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + use psb_base_mod + use psb_z_prec_type, psb_protect_name => psb_zcprecsetc + implicit none + + class(psb_zprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + ! This optional inputs are backport from the inputs available in AMG4PSBLAS, + ! they are of no actual use here a part from compatibility reasons. + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + + ! Local variables + character(len=*), parameter :: name='psb_precsetc' + + info = psb_success_ + + ! We need to convert from the 'what' string to the corresponding integer + ! value befor passing the call to the set of the inner method. + select case (psb_toupper(trim(what))) + case ('SUB_SOLVE') + ! We select here the type of solver on the block + select case (psb_toupper(trim(string))) + case("ILU") + call prec%prec%precset(psb_f_type_,psb_f_ilu_k_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + case("ILUT") + call prec%prec%precset(psb_f_type_,psb_f_ilu_t_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_t_,info) + case("AINV") + call prec%prec%precset(psb_f_type_,psb_f_ainv_,info) + case("INVK") + call prec%prec%precset(psb_f_type_,psb_f_invk_,info) + case("INVT") + call prec%prec%precset(psb_f_type_,psb_f_invt_,info) + case default + ! Default to ILU(0) factorization + call prec%prec%precset(psb_f_type_,psb_f_ilu_n_,info) + call prec%prec%precset(psb_ilu_ialg_,psb_ilu_n_,info) + end select + case ("ILU_ALG") + select case (psb_toupper(trim(string))) + case ("MILU") + call prec%prec%precset(psb_ilu_ialg_,psb_milu_n_,info) + case default + ! Do nothing + end select + case ("ILUT_SCALE") + select case (psb_toupper(trim(string))) + case ("MAXVAL") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_maxval_,info) + case ("DIAG") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_diag_,info) + case ("ARWSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arwsum_,info) + case ("ARCSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_arcsum_,info) + case ("ACLSUM") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_aclsum_,info) + case ("NONE") + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + case default + call prec%prec%precset(psb_ilu_scale_,psb_ilu_scale_none_,info) + end select + case ("AINV_ALG") + select case (psb_toupper(trim(string))) + case("LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + case("SYM-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_llk_,info) + case("STAB-LLK") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_s_ft_llk_,info) + case("MLK","LMX") + call prec%prec%precset(psb_ainv_alg_,psb_ainv_mlk_,info) + case default + call prec%prec%precset(psb_ainv_alg_,psb_ainv_llk_,info) + end select + case default + + end select + +end subroutine psb_zcprecsetc diff --git a/prec/impl/psb_z_sp_drop.f90 b/prec/impl/psb_z_sp_drop.f90 new file mode 100644 index 00000000..754c76cc --- /dev/null +++ b/prec/impl/psb_z_sp_drop.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_z_sp_drop(idiag,nzrmax,sp_thresh,nz,iz,valz,info) + use psb_base_mod + implicit none + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, nzrmax + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: iz(:) + complex(psb_dpk_), intent(inout) :: valz(:) + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i, j, idf, nw + complex(psb_dpk_) :: witem + integer(psb_ipk_) :: widx + complex(psb_dpk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + + if (nz > min(size(iz),size(valz))) then + write(0,*) 'Serious size problem ',nz,size(iz),size(valz) + info = -2 + return + end if + allocate(xw(nz),xwid(nz),indx(nz),stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory allocation failure in sp_drop',nz,info + return + endif + + ! Always keep the diagonal element + idf = -1 + do i=1, nz + if (iz(i) == idiag) then + idf = i + witem = valz(i) + widx = iz(i) + valz(i) = valz(1) + iz(i) = iz(1) + valz(1) = witem + iz(1) = widx + exit + end if + end do + + if (idf == -1) then + + xw(1:nz) = valz(1:nz) + call psb_qsort(xw(1:nz),indx(1:nz),dir=psb_asort_down_) + do i=1, nz + xwid(i) = iz(indx(i)) + end do + nw = min(nz,nzrmax) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + nw = max(nw, 1) + + else + + nw = nz-1 + + xw(1:nw) = valz(2:nz) + + call psb_qsort(xw(1:nw),indx(1:nw),dir=psb_asort_down_) + nw = min(nw,nzrmax-1) + do + if (nw <= 1) exit + if (abs(xw(nw)) < sp_thresh) then + nw = nw - 1 + else + exit + end if + end do + + do i=1, nw + xwid(i) = iz(1+indx(i)) + end do + nw = nw + 1 + xw(nw) = valz(1) + xwid(nw) = iz(1) + end if + + call psb_msort(xwid(1:nw),indx(1:nw),dir=psb_sort_up_) + + do i=1, nw + valz(i) = xw(indx(i)) + iz(i) = xwid(i) + end do + nz = nw + if (nz>nzrmax) write(0,*) 'in sp_drop: ',nw,nzrmax,nz + deallocate(xw,xwid,indx,stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) ' Memory deallocation failure in sp_drop',info + return + endif + return +end subroutine psb_z_sp_drop diff --git a/prec/impl/psb_z_sparsify.f90 b/prec/impl/psb_z_sparsify.f90 new file mode 100644 index 00000000..fe29230f --- /dev/null +++ b/prec/impl/psb_z_sparsify.f90 @@ -0,0 +1,260 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_z_sparsify(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,info,istart,iheap,ikr) + use psb_base_mod + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + complex(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: istart + type(psb_i_heap), optional :: iheap + integer(psb_ipk_), optional :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k + complex(psb_dpk_) :: witem + integer(psb_ipk_) :: widx + complex(psb_dpk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + type(psb_z_idx_heap) :: heap + + + info = psb_success_ + istart_ = 1 + if (present(istart)) istart_ = max(1,istart) + if (.false.) then + nz = 0 + do i=istart_, n + if ((i == idiag).or.(abs(zw(i)) >= sp_thresh)) then + nz = nz + 1 + iz(nz) = i + valz(nz) = zw(i) + end if + end do + + else + allocate(xw(nzrmax),xwid(nzrmax),indx(nzrmax),stat=info) + if (info /= psb_success_) then + return + end if + + call heap%init(info,dir=psb_asort_down_) + + ! Keep at least the diagonal + nz = 0 + + if (present(iheap)) then + if (.not.(present(ikr))) then + write(psb_err_unit,*) 'Error: if IHEAP then also IKR' + info = -1 + return + end if + last_i = -1 + do + call iheap%get_first(i,iret) + if (iret < 0) exit + ! An index may have been put on the heap more than once. + if (i == last_i) cycle + last_i = i + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + ikr(i) = 0 + end do + + else + + do i=istart_, n + if (i == idiag) then + xw(1) = zw(i) + xwid(1) = i + else if (abs(zw(i)) >= sp_thresh) then + call heap%insert(zw(i),i,info) + end if + zw(i) = dzero + end do + end if + + k = 1 + do + if (k == nzrmax) exit + call heap%get_first(witem,widx,info) + if (info == -1) then + info = psb_success_ + exit + endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + return + end if + k = k + 1 + xw(k) = witem + xwid(k) = widx + end do + call heap%free(info) + nz = k + call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + end if + + return + +end subroutine psb_z_sparsify + + +subroutine psb_z_sparsify_list(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,lhead,listv,ikr,info) + use psb_base_mod + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + complex(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: lhead, listv(:) + integer(psb_ipk_) :: ikr(:) + ! + integer(psb_ipk_) :: i, istart_, last_i, iret,k,current, next + complex(psb_dpk_) :: witem + integer(psb_ipk_) :: widx + complex(psb_dpk_), allocatable :: xw(:) + integer(psb_ipk_), allocatable :: xwid(:), indx(:) + + + info = psb_success_ + istart_ = 1 + allocate(xw(n),xwid(n),indx(n),stat=info) + + current = lhead + lhead = -1 + i = 0 + do while (current >0) + i = i + 1 + xw(i) = zw(current) + xwid(i) = current + + if (current == idiag) then + ! Bring the diagona into first position + witem = xw(1) + widx = xwid(1) + xw(1) = xw(i) + xwid(1) = xwid(i) + xw(i) = witem + xwid(i) = widx + end if + + zw(current) = dzero + ikr(current) = 0 + + next = listv(current) + listv(current) = -1 + current = next + end do + nz = i + if (nz > 2) call psb_hsort(xw(2:nz),ix=xwid(2:nz),& + & dir=psb_asort_down_,flag=psb_sort_keep_idx_) +!!$ write(0,*) 'Done first msort ' +!!$ write(0,*) ' after first msort for idiag ',idiag,' :',nz,sp_thresh +!!$ do i=1, nz +!!$ write(0,*) ' ',xwid(i),xw(i) +!!$ end do + + i = 2 + do while (i<=nz) + if (abs(xw(i)) < sp_thresh) exit + i = i + 1 + end do +!!$ write(0,*) 'NZ ',nz, i, nzrmax + nz = max(1,min(i-1,nzrmax)) + call psb_msort(xwid(1:nz),ix=indx(1:nz),dir=psb_sort_up_) +!!$ write(0,*) 'Done second msort ' + +!!$ write(0,*) 'sparsify output for idiag ',idiag,' :',nz,i,sp_thresh + do i=1, nz + valz(i) = xw(indx(i)) + iz(i) = xwid(i) +!!$ write(0,*) ' ',iz(i),valz(i) + end do + + return + +end subroutine psb_z_sparsify_list diff --git a/prec/impl/psb_zprecbld.f90 b/prec/impl/psb_zprecbld.f90 index b99cfe92..3c584947 100644 --- a/prec/impl/psb_zprecbld.f90 +++ b/prec/impl/psb_zprecbld.f90 @@ -44,7 +44,8 @@ subroutine psb_zprecbld(a,desc_a,p,info,amold,vmold,imold) class(psb_i_base_vect_type), intent(in), optional :: imold ! Local scalars - integer(psb_ipk_) :: ictxt, me,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err @@ -58,9 +59,9 @@ subroutine psb_zprecbld(a,desc_a,p,info,amold,vmold,imold) end if info = psb_success_ - ictxt = desc_a%get_context() + ctxt = desc_a%get_context() - call psb_info(ictxt, me, np) + call psb_info(ctxt, me, np) n_row = desc_a%get_local_rows() n_col = desc_a%get_local_cols() diff --git a/prec/impl/psb_zprecinit.f90 b/prec/impl/psb_zprecinit.f90 index d9f5aa01..167a43ec 100644 --- a/prec/impl/psb_zprecinit.f90 +++ b/prec/impl/psb_zprecinit.f90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psb_zprecinit(ictxt,p,ptype,info) +subroutine psb_zprecinit(ctxt,p,ptype,info) use psb_base_mod use psb_z_prec_type, psb_protect_name => psb_zprecinit @@ -37,7 +37,7 @@ subroutine psb_zprecinit(ictxt,p,ptype,info) use psb_z_diagprec, only : psb_z_diag_prec_type use psb_z_bjacprec, only : psb_z_bjac_prec_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_zprec_type), intent(inout) :: p character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -50,7 +50,7 @@ subroutine psb_zprecinit(ictxt,p,ptype,info) if (info /= psb_success_) return end if - p%ictxt = ictxt + p%ctxt = ctxt select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NONE','NOPREC') diff --git a/prec/impl/psb_zrwclip.f90 b/prec/impl/psb_zrwclip.f90 new file mode 100644 index 00000000..574ebcf8 --- /dev/null +++ b/prec/impl/psb_zrwclip.f90 @@ -0,0 +1,90 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_z_rwclip(nz,ia,ja,val,imin,imax,jmin,jmax) + use psb_base_mod + + implicit none + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: ia(*), ja(*) + complex(psb_dpk_), intent(inout) :: val(*) + integer(psb_ipk_), intent(in) :: imin,imax,jmin,jmax + + integer(psb_ipk_) :: i,j + + j = 0 + do i=1, nz + if ((imin <= ia(i)).and.& + & (ia(i) <= imax).and.& + & (jmin <= ja(i)).and.& + & (ja(i) <= jmax) ) then + j = j + 1 + ia(j) = ia(i) + ja(j) = ja(i) + val(j) = val(i) + end if + end do + nz = j +end subroutine psb_z_rwclip diff --git a/prec/impl/psb_zsparse_biconjg_llk.F90 b/prec/impl/psb_zsparse_biconjg_llk.F90 new file mode 100644 index 00000000..2d3a90cb --- /dev/null +++ b/prec/impl/psb_zsparse_biconjg_llk.F90 @@ -0,0 +1,366 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_zsparse_biconjg_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_z_ainv_tools_mod + use psb_z_biconjg_mod, psb_protect_name => psb_zsparse_biconjg_llk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + complex(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + complex(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_z_csc_sparse_mat) :: ac + complex(psb_dpk_) :: alpha + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = zzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = zzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = zone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = zone + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = zzero + ! !$ end do + zval(i) = zone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then +!!$ write(0,*) i, ' Outer inserting ',ac%ia(j) + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! ! write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha + if (.false..or.(abs(alpha) > sp_thresh)) then +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_zsparse_biconjg_llk_noth + + ! + ! Left-looking variant, with NO drop rule on p(i)/p(j) + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + complex(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + complex(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw + type(psb_i_heap) :: heap, rheap + type(psb_z_csc_sparse_mat) :: ac + real(psb_dpk_) :: alpha + character(len=20) :: name='psb_orth_llk_noth' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = zzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = zzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = done + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = done + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = zzero + ! !$ end do + zval(i) = done + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.true.) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.true.) then + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_zsparse_biconjg_mlk + ! + ! Left-looking variant + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + complex(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:), hlist(:), bfr(:), rwlist(:) + complex(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, hlhead, li, mj, kkc, ifrst, ilst, rwhead + type(psb_i_heap) :: heap, rheap + type(psb_z_csc_sparse_mat) :: ac + complex(psb_dpk_) :: alpha + character(len=20) :: name='psb_biconjg_mlk' + logical, parameter :: debug=.false., test_merge=.true. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n), & + & hlist(n),rwlist(n),bfr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = zzero + hlist(i) = -1 + rwlist(i) = -1 + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = zzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = zone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = zone + nzw = 1 + + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = zzero + ! !$ end do + zval(i) = zone + izkr(i) = 1 + rwhead = i + + hlhead = -1 + + kkc = 0 + ilst = ac%icp(i)-1 + ifrst = ac%icp(i) + do j = ac%icp(i+1)-1, ac%icp(i), -1 + if (ac%ia(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (.true..or.debug) then +!!$ write(0,*) 'Outer Before insertion : ',hlhead + call printlist(hlhead,hlist) + end if + if (kkc > 0) then +!!$ write(0,*) i,' Outer Inserting : ',kkc,':',ac%ia(ifrst:ilst) + + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + mj = hlhead + if (mj > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outer + + izcr(j) = 0 + if (j>=i) cycle outer + + if (debug) write(0,*) 'update loop, using row: ',j,i,mj + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) +!!$ write(0,*) 'At step ',i,j,' p(i) ',p(i),alpha +!!$ write(0,*) ' Current list is : ',hlhead +!!$ call printlist(hlhead,hlist) +!!$ + + + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=z%icp(j) + ilst=z%icp(j+1)-1 + call hlmerge(rwhead,rwlist,z%ia(ifrst:ilst)) +!!$ write(0,*) 'At step ',i,j,' range ',z%icp(j), z%icp(j+1)-1, & +!!$ & ' vals ',z%ia(z%icp(j):z%icp(j+1)-1) + + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + + if (izkr(kr) == 0) then +!!$ write(0,*) ' main inner Inserting ',kr +!!$ call hlmerge(rwhead,rwlist,(/kr/)) + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',ac%ia(ifrst:ilst) + end if + if (ilst >= ifrst) then +!!$ write(0,*) j,i,' Inner inserting ',ac%ia(ifrst:ilst) + call hlmerge(hlhead,hlist,ac%ia(ifrst:ilst)) + end if + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outer + call a%csget(i,i,nzra,ia,ja,val,info) + call rwclip(nzra,ia,ja,val,ione,n,ione,n) + p(i) = psb_spge_dot(nzra,ja,val,zval) + if (abs(p(i)) < d_epstol) & + & p(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzz+nzrz, z%ia, info) + call psb_ensure_size(nzz+nzrz, z%val, info) + ipz1 = z%icp(i) + do j=1, nzrz + z%ia(ipz1 + j -1) = ia(j) + z%val(ipz1 + j -1) = val(j) + end do + z%icp(i+1) = ipz1 + nzrz + nzz = nzz + nzrz + + + ! WVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = zzero + ! !$ end do + zval(i) = zone + izkr(i) = 1 + rwhead = i + hlhead = -1 + + kkc = 0 + ilst = a%irp(i)-1 + ifrst = a%irp(i) + do j = a%irp(i+1)-1, a%irp(i), -1 + if (a%ja(j) < i) then + ilst = j + exit + end if + end do + kkc = ilst-ifrst+1 + + if (debug) then + write(0,*) 'Outer Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Outer Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + if (kkc > 0 ) then + !call hlmerge(hlhead,hlist,bfr(1:kkc)) + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + end if + if (debug) then + write(0,*) 'Outer After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='init_lists') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outerw: do + mj = hlhead + if (hlhead > 0) then + hlhead = hlist(mj) + hlist(mj) = -1 + end if + j = mj + if (j < 0) exit outerw + + izcr(j) = 0 + if (j>=i) cycle outerw + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-q(i)/q(j)) + if (.false..or.(abs(alpha) > sp_thresh)) then + ifrst=w%icp(j) + ilst=w%icp(j+1)-1 + call hlmerge(rwhead,rwlist,w%ia(ifrst:ilst)) + + do k=w%icp(j), w%icp(j+1)-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj)) then + ifrst = min(ifrst,kc ) + ilst = max(ilst,kc) + end if + end do + kkc = ilst-ifrst+1 + if (debug) then + write(0,*) 'Inner Before insertion: ' + call printlist(hlhead,hlist) + write(0,*) 'Inner Inserting : ',kkc,':',a%ja(ifrst:ilst) + end if + + call hlmerge(hlhead,hlist,a%ja(ifrst:ilst)) + + if (debug) then + write(0,*) 'Inner After insertion: ',hlhead + call printlist(hlhead,hlist) + end if + if (debug) write(0,*) 'update loop, adding indices: ',& + & a%ja(a%irp(kr):a%irp(kr+1)-1) + + end if + if (info /= psb_success_) exit + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + return + end if + end if + end do outerw + ip1 = ac%icp(i) + ip2 = ac%icp(i+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + if (abs(q(i)) < d_epstol) & + & q(i) = 1.d-3 + +!!$ write(0,*) 'Dropping from a column with: ',i,psb_howmany_heap(heap),sp_thresh + ! + ! Sparsify current ZVAL and put into ZMAT + ! + call sparsify(i,nzrmax,sp_thresh,n,zval,nzrz,ia,val,rwhead,rwlist,izkr,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='sparsify') + return + end if + call psb_ensure_size(nzw+nzrz, w%ia, info) + call psb_ensure_size(nzw+nzrz, w%val, info) + ipz1 = w%icp(i) + do j=1, nzrz + w%ia(ipz1 + j -1) = ia(j) + w%val(ipz1 + j -1) = val(j) + end do + w%icp(i+1) = ipz1 + nzrz + nzw = nzw + nzrz + + end do + +contains + + subroutine hlmerge(head,listv,vals) + integer(psb_ipk_), intent(inout) :: head, listv(:) + integer(psb_ipk_), intent(in) :: vals(:) + integer(psb_ipk_) :: i,j,k, lh, lv, nv, vv, flh, ph + + nv = size(vals) + lh = head + flh = -1 + lv = 1 + if ((head < 0).and.(nv > 0)) then + ! Adjust head if empty + head = vals(lv) + lv = lv + 1 + else if ((head > 0) .and. (nv >0)) then + ! Adjust head if first item less than it + if (head > vals(lv)) then + listv(vals(lv)) = head + head = vals(lv) + lv = lv + 1 + end if + end if + + lh = head + ph = lh + do while ((lh > 0) .and. (lv <= nv)) + if (lh == vals(lv)) then + lv = lv + 1 + else if (lh > vals(lv)) then + listv(vals(lv)) = lh + listv(ph) = vals(lv) + lh = vals(lv) + lv = lv + 1 + else + ph = lh + lh = listv(lh) + end if + end do + lh = ph + do while (lv <= nv) + listv(lh) = vals(lv) + lh = listv(lh) + lv = lv + 1 + end do + end subroutine hlmerge + + + subroutine printlist(head,listv) + integer(psb_ipk_), intent(in) :: head, listv(:) + integer(psb_ipk_) :: li + + li = head + do while (li > 0) + write(0,*) 'Item: ', li + li = listv(li) + end do + end subroutine printlist + +end subroutine psb_zsparse_biconjg_mlk diff --git a/prec/impl/psb_zsparse_biconjg_s_ft_llk.F90 b/prec/impl/psb_zsparse_biconjg_s_ft_llk.F90 new file mode 100644 index 00000000..541a755c --- /dev/null +++ b/prec/impl/psb_zsparse_biconjg_s_ft_llk.F90 @@ -0,0 +1,414 @@ +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +subroutine psb_zsparse_biconjg_s_ft_llk(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_z_ainv_tools_mod + use psb_z_biconjg_mod, psb_protect_name => psb_zsparse_biconjg_s_ft_llk + + ! + ! Left-looking variant, stabilized i.e. product by A is applied + ! to compute the diagonal elements. + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + complex(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:),iww(:) + complex(psb_dpk_), allocatable :: zval(:),val(:), q(:), ww(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj, nzww,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw, nzrw + type(psb_i_heap) :: heap, rheap + type(psb_z_csc_sparse_mat) :: ac + complex(psb_dpk_) :: alpha, tmpq,tmpq2 + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),q(n),iww(n),ww(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! Init pointers to: + ! ljr(i): last occupied column index within row I + ! izcr(i): first occupied row index within column I + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = zzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = zzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + q(1) = p(1) + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = zone + nzz = 1 + + call w%allocate(n,n,n*nzrmax) + w%icp(1) = 1 + w%icp(2) = 2 + w%ia(1) = 1 + w%val(1) = zone + nzw = 1 + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = zzero + ! !$ end do + zval(i) = zone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) lastj) then + lastj = j + exit inner + end if + end do inner + izcr(j) = 0 + if (j>=i) exit outer + if (debug) write(0,*) 'update loop, using row: ',j + ip1 = w%icp(j) + ip2 = w%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_z_spvspm(zone,a,nzra,w%ia(ip1:ip2),w%val(ip1:ip2),& + & zzero,nzww,iww,ww,info) + + p(i) = psb_spge_dot(nzww,iww,ww,zval) + + ipz1 = z%icp(j) + ipz2 = z%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-p(i)/p(j)) +!!$ write(0,*) ' p(i)/p(j) ',i,j,alpha,p(i),p(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj lastj) then + lastj = j + exit innerw + end if + end do innerw + izcr(j) = 0 + if (j>=i) exit outerw + if (debug) write(0,*) 'update loop, using row: ',j + if (.false.) then + ip1 = ac%icp(j) + ip2 = ac%icp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (ac%ia(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + q(i) = psb_spge_dot(nzra,ac%ia(ip1:ip2),ac%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + else + ip1 = z%icp(j) + ip2 = z%icp(j+1) - 1 + nzra = max(0,ip2 - ip1 + 1) + nzww = 0 + call psb_z_spmspv(zone,ac,nzra,z%ia(ip1:ip2),z%val(ip1:ip2),& + & zzero,nzww,iww,ww,info) + + q(i) = psb_spge_dot(nzww,iww,ww,zval) + end if + + ipz1 = w%icp(j) + ipz2 = w%icp(j+1) + nzrz = ipz2-ipz1 + alpha = (-q(i)/q(j)) +!!$ write(0,*) ' q(i)/q(j) ',i,j,alpha,q(i),q(j) + if (.false..or.(abs(alpha) > sp_thresh)) then + + do k=ipz1, ipz2-1 + kr = w%ia(k) + zval(kr) = zval(kr) + alpha*w%val(k) + if (izkr(kr) == 0) then + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_zsparse_biconjg_s_llk + + ! + ! Left-looking variant SYMMETRIC/HERMITIAN A. You have been warned! + ! + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + complex(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + ! Locals + integer(psb_ipk_), allocatable :: ia(:), ja(:), izkr(:), izcr(:) + complex(psb_dpk_), allocatable :: zval(:),val(:), q(:) + integer(psb_ipk_) :: i,j,k, kc, kr, err_act, nz, nzra, nzrz, ipzi,ipzj,& + & nzzi,nzzj, nzz, ip1, ip2, ipza,ipzz, ipzn, nzzn, ipz1, ipz2,& + & ipj, lastj, nextj, nzw,kk + type(psb_i_heap) :: heap, rheap + type(psb_z_csc_sparse_mat) :: ac + complex(psb_dpk_) :: alpha, zvalmax + character(len=20) :: name='psb_orth_llk' + logical, parameter :: debug=.false. + + allocate(zval(n),ia(n),val(n),izkr(n),izcr(n),stat=info) + if (info == psb_success_) call ac%cp_from_fmt(a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + return + end if + ! + ! izkr(i): flag nonzeros in ZVAL. To minimize traffic into heap. + ! izcr(i): flag rows to be used for the dot products. Used to minimize + ! traffic in rheap. + ! + do i=1,n + izkr(i) = 0 + izcr(i) = 0 + zval(i) = zzero + end do + + ! Init z_1=e_1 and p_1=a_11 + p(1) = zzero + i = 1 + nz = a%irp(i+1) - a%irp(i) + do j=1,nz + if (a%ja(j) == 1) then + p(1) = a%val(j) + exit + end if + end do + if (abs(p(1)) < d_epstol) & + & p(1) = 1.d-3 + + ! + ! + call z%allocate(n,n,n*nzrmax) + + z%icp(1) = 1 + z%icp(2) = 2 + z%ia(1) = 1 + z%val(1) = zone + nzz = 1 + zvalmax = zone + + do i = 2, n + if (debug) write(0,*) 'Main loop iteration ',i,n + + ! + ! Update loop on Z. + ! Must be separated from update loop of W because of + ! the conflict on J that would result. + ! + + ! ZVAL = e_i + ! !$ do j=1, i-1 + ! !$ zval(j) = zzero + ! !$ end do + zval(i) = zone + izkr(i) = 1 + call heap%init(info) + if (info == psb_success_) call heap%insert(i,info) + + if (info == psb_success_) call rheap%init(info) + do j = ac%icp(i), ac%icp(i+1)-1 + if (ac%ia(j) < i) then + if (info == psb_success_) call rheap%insert(ac%ia(j),info) + izcr(ac%ia(j)) = 1 + end if + end do + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_init_heap') + return + end if + + ! Update loop + ! The idea is to keep track of the indices of the nonzeros in zval, + ! so as to only do the dot products on the rows which have nonzeros + ! in their positions; to do this we keep an extra + ! copy of A in CSC, and the row indices to be considered are in rheap. + lastj = -1 + outer: do + inner: do + call rheap%get_first(j,info) + if (debug) write(0,*) 'from get_first: ',j,info + if (info == -1) exit outer ! Empty heap + if (j > lastj) then + lastj = j + exit inner + end if + end do inner + + izcr(j) = 0 + if (j>=i) cycle outer + if (debug) write(0,*) 'update loop, using row: ',j,i + ip1 = a%irp(j) + ip2 = a%irp(j+1) - 1 + do + if (ip2 < ip1 ) exit + if (a%ja(ip2) <= n) exit + ip2 = ip2 -1 + end do + nzra = max(0,ip2 - ip1 + 1) + p(i) = psb_spge_dot(nzra,a%ja(ip1:ip2),a%val(ip1:ip2),zval) + ! !$ write(psb_err_unit,*) j,i,p(i) + + alpha = (-p(i)/p(j)) + + if (.false..or.(abs(alpha) > sp_thresh)) then + do k=z%icp(j), z%icp(j+1)-1 + kr = z%ia(k) + zval(kr) = zval(kr) + alpha*z%val(k) +!!$ if (abs(zval(kr)) > 1e16) then +!!$ write(0,*) i,j,p(i),p(j),alpha,z%val(k),alpha*z%val(k),kr,zval(kr) +!!$ end if + if (izkr(kr) == 0) then + + call heap%insert(kr,info) + if (info /= psb_success_) exit + izkr(kr) = 1 + ! We have just added a new nonzero in KR. Thus, we will + ! need to explicitly compute the dot products on all + ! rows jj).and.(nextj psb_c_base_set_ctxt procedure, pass(prec) :: get_ctxt => psb_c_base_get_ctxt @@ -342,12 +343,12 @@ contains end function psb_c_base_is_allocated_wrk - subroutine psb_c_base_set_ctxt(prec,ictxt) + subroutine psb_c_base_set_ctxt(prec,ctxt) implicit none class(psb_c_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type) :: ctxt - prec%ictxt = ictxt + prec%ctxt = ctxt end subroutine psb_c_base_set_ctxt @@ -361,9 +362,9 @@ contains function psb_c_base_get_ctxt(prec) result(val) class(psb_c_base_prec_type), intent(in) :: prec - integer(psb_ipk_) :: val + type(psb_ctxt_type) :: val - val = prec%ictxt + val = prec%ctxt return end function psb_c_base_get_ctxt @@ -382,10 +383,11 @@ contains character(len=32) :: res ! character(len=32) :: frmtv - integer(psb_ipk_) :: ni, ictxt,iam,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: ni, iam, np - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) res = '' if (iam /= psb_root_) then diff --git a/prec/psb_c_biconjg_mod.F90 b/prec/psb_c_biconjg_mod.F90 new file mode 100644 index 00000000..6af30b4f --- /dev/null +++ b/prec/psb_c_biconjg_mod.F90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +module psb_c_biconjg_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_sparse_biconjg + module procedure psb_csparse_biconjg + end interface + + abstract interface + subroutine psb_csparse_biconjg_variant(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod, only : psb_c_csr_sparse_mat, psb_c_csc_sparse_mat, & + & psb_spk_, psb_ipk_ + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + complex(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_csparse_biconjg_variant + end interface + + + procedure(psb_csparse_biconjg_variant) :: psb_csparse_biconjg_llk,& + & psb_csparse_biconjg_s_llk, psb_csparse_biconjg_s_ft_llk,& + & psb_csparse_biconjg_llk_noth, psb_csparse_biconjg_mlk + +#if defined(HAVE_TUMA_SAINV) + procedure(psb_csparse_biconjg_variant) :: psb_csparse_tuma_sainv,& + & psb_csparse_tuma_lainv +#endif + +contains + + subroutine psb_csparse_biconjg(alg,n,acsr,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_prec_const_mod + integer(psb_ipk_), intent(in) :: alg,n + type(psb_c_csr_sparse_mat), intent(in) :: acsr + type(psb_cspmat_type), intent(out) :: z, w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + complex(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_c_csc_sparse_mat) :: zcsc,wcsc + integer(psb_ipk_) :: i,j,k,nrm + integer(psb_ipk_) :: err_act + character(len=20) :: name='psb_sparse_biconjg' + integer(psb_ipk_), parameter :: variant=1 + + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (size(p) precout) - type is (psb_c_bjac_prec_type) + type is (psb_c_bjac_prec_type) call pout%set_ctxt(prec%get_ctxt()) - if (allocated(prec%av)) then + if (allocated(prec%av)) then allocate(pout%av(size(prec%av)),stat=info) - do i=1,size(prec%av) + do i=1,size(prec%av) if (info /= psb_success_) exit call prec%av(i)%clone(pout%av(i),info) enddo if (info /= psb_success_) goto 9999 end if - if (allocated(prec%dv)) then + if (allocated(prec%dv)) then allocate(pout%dv,stat=info) if (info == 0) call prec%dv%clone(pout%dv,info) end if @@ -315,7 +330,7 @@ contains subroutine psb_c_bjac_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_c_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -325,11 +340,11 @@ contains ! Local variables integer(psb_ipk_) :: err_act, i character(len=20) :: name - + info=psb_success_ name = 'psb_c_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 if (allocated(prec%wrk)) then if (size(prec%wrk)<2) then @@ -342,11 +357,11 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + if (.not.allocated(prec%wrk)) then - if (.not.present(desc)) then + if (.not.present(desc)) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="no desc?"); goto 9999 - end if + end if allocate(prec%wrk(2),stat=info) do i=1, 2 if (info == 0) call psb_geall(prec%wrk(i),desc,info) @@ -356,19 +371,19 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="allocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_c_bjac_allocate_wrk subroutine psb_c_bjac_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_c_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -377,14 +392,14 @@ contains integer(psb_ipk_) :: err_act integer(psb_ipk_) :: i character(len=20) :: name - + info=psb_success_ name = 'psb_c_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - info = psb_success_ + info = psb_success_ if (allocated(prec%wrk)) then do i=1,size(prec%wrk) if (info == 0) call prec%wrk(i)%free(info) @@ -394,29 +409,29 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_c_bjac_free_wrk function psb_c_bjac_is_allocated_wrk(prec) result(res) use psb_base_mod implicit none - + ! Arguments class(psb_c_bjac_prec_type), intent(in) :: prec logical :: res - ! In the base version we can say yes, because + ! In the base version we can say yes, because ! there is nothing to allocate res = allocated(prec%wrk) - + end function psb_c_bjac_is_allocated_wrk - + end module psb_c_bjacprec diff --git a/prec/psb_c_diagprec.f90 b/prec/psb_c_diagprec.f90 index f2eaa4d0..c3deb6d8 100644 --- a/prec/psb_c_diagprec.f90 +++ b/prec/psb_c_diagprec.f90 @@ -171,7 +171,8 @@ contains integer(psb_ipk_) :: err_act, nrow, info character(len=20) :: name='c_diag_precdescr' - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -188,8 +189,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam diff --git a/prec/psb_c_invk_fact_mod.f90 b/prec/psb_c_invk_fact_mod.f90 new file mode 100644 index 00000000..620a8adf --- /dev/null +++ b/prec/psb_c_invk_fact_mod.f90 @@ -0,0 +1,165 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_c_invk_fact_mod.f90 +! +! Module: psb_c_invk_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_c_invk_solver, but not visible to the end user. +! +! +module psb_c_invk_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invk_fact + subroutine psb_c_invk_bld(a,fill1, fill2,lmat,d,umat,desc,info,blck) + ! import + import psb_cspmat_type, psb_ipk_, psb_spk_, psb_desc_type + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_cspmat_type), intent(inout) :: lmat, umat + complex(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: blck + end subroutine + end interface + + ! Inner workings + interface psb_sparse_invk + subroutine psb_csparse_invk(n,a,z,fill_in,info,inlevs) + ! Import + import psb_ipk_, psb_cspmat_type + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_csparse_invk + end interface + + interface psb_invk_inv + subroutine psb_cinvk_inv(fill_in,i,row,rowlevs,heap,uia1,uia2,uaspk,uplevs,& + & nidx,idxs,info) + + use psb_base_mod, only : psb_cspmat_type, psb_spk_, psb_i_heap, psb_ipk_ + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: uia1(:),uia2(:),uplevs(:) + complex(psb_spk_), intent(in) :: uaspk(:) + complex(psb_spk_), intent(inout) :: row(:) + + + end subroutine psb_cinvk_inv + end interface + + interface psb_invk_copyin + subroutine psb_c_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,& + & ktrw,trw,info,sign,inlevs) + ! Import + use psb_base_mod, only : psb_c_csr_sparse_mat, psb_c_coo_sparse_mat,& + & psb_spk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + complex(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_c_invk_copyin + end interface + + interface psb_invk_copyout + subroutine psb_c_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + use psb_base_mod, only : psb_cspmat_type, psb_spk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + complex(psb_spk_), allocatable, intent(inout) :: uaspk(:) + complex(psb_spk_), intent(inout) :: row(:) + end subroutine psb_c_invk_copyout + end interface + +end module diff --git a/prec/psb_c_invt_fact_mod.f90 b/prec/psb_c_invt_fact_mod.f90 new file mode 100644 index 00000000..841c39b1 --- /dev/null +++ b/prec/psb_c_invt_fact_mod.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_c_invt_fact_mod.f90 +! +! Module: psb_c_invt_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_c_invt_solver, but not visible to the end user. +! +! +module psb_c_invt_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invt_fact + subroutine psb_c_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + ! Import + import psb_cspmat_type, psb_spk_, psb_ipk_, psb_desc_type + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_spk_), intent(in) :: thresh + real(psb_spk_), intent(in) :: invthresh + type(psb_cspmat_type), intent(inout) :: lmat, umat + complex(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), optional :: blck + end subroutine psb_c_invt_bld + end interface + + ! Interfaces for the inner workings + + interface + subroutine psb_csparse_invt(n,a,z,nzrmax,sp_thresh,info) + ! Import + import psb_cspmat_type, psb_spk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_cspmat_type), intent(in) :: a + type(psb_cspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + end subroutine psb_csparse_invt + end interface + + interface + subroutine psb_c_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + ! Import + import psb_c_csr_sparse_mat, psb_c_coo_sparse_mat, psb_spk_, & + & psb_ipk_, psb_i_heap + ! Arguments + type(psb_c_csr_sparse_mat), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(inout) :: nrmi + complex(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), intent(in), optional :: sign + end subroutine psb_c_invt_copyin + end interface + + interface + subroutine psb_c_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + ! Import + import psb_spk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_spk_), intent(in) :: thres,nrmi + complex(psb_spk_),allocatable, intent(inout) :: val(:) + complex(psb_spk_), intent(inout) :: row(:) + end subroutine psb_c_invt_copyout + end interface + + interface psb_invt_inv + subroutine psb_c_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val, & + & nidx,idxs,info) + ! import + import psb_spk_, psb_i_heap, psb_ipk_ + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: row(:) + end subroutine + end interface + +contains + +end module psb_c_invt_fact_mod diff --git a/prec/psb_c_nullprec.f90 b/prec/psb_c_nullprec.f90 index 9a75366e..ac23a3db 100644 --- a/prec/psb_c_nullprec.f90 +++ b/prec/psb_c_nullprec.f90 @@ -170,7 +170,8 @@ contains character(len=20) :: name='c_null_precset' character(len=32) :: dprefix, frmtv integer(psb_ipk_) :: ni - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -187,8 +188,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam @@ -212,7 +213,8 @@ contains class(psb_c_null_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: iout, iam, np, ictxt, lname + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout, iam, np, lname logical :: isopen character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than @@ -220,8 +222,8 @@ contains ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/psb_c_prec_type.f90 b/prec/psb_c_prec_type.f90 index 6d9aa908..38080cee 100644 --- a/prec/psb_c_prec_type.f90 +++ b/prec/psb_c_prec_type.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,8 +27,8 @@ ! 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. -! -! +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Module to define PREC_DATA, !! !! structure for preconditioning. !! @@ -39,7 +39,7 @@ module psb_c_prec_type use psb_c_base_prec_mod type psb_cprec_type - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt class(psb_c_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: psb_c_apply1_vect @@ -54,6 +54,10 @@ module psb_c_prec_type procedure, pass(prec) :: build => psb_cprecbld procedure, pass(prec) :: init => psb_cprecinit procedure, pass(prec) :: descr => psb_cfile_prec_descr + procedure, pass(prec) :: cseti => psb_ccprecseti + procedure, pass(prec) :: csetc => psb_ccprecsetc + procedure, pass(prec) :: csetr => psb_ccprecsetr + generic, public :: set => cseti, csetc, csetr procedure, pass(prec) :: allocate_wrk => psb_c_allocate_wrk procedure, pass(prec) :: free_wrk => psb_c_free_wrk procedure, pass(prec) :: is_allocated_wrk => psb_c_is_allocated_wrk @@ -64,10 +68,10 @@ module psb_c_prec_type end interface interface psb_precinit - subroutine psb_cprecinit(ictxt,prec,ptype,info) - import :: psb_ipk_, psb_cprec_type + subroutine psb_cprecinit(ctxt,prec,ptype,info) + import :: psb_ipk_, psb_cprec_type, psb_ctxt_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_cprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -102,7 +106,7 @@ module psb_c_prec_type module procedure psb_cprec_sizeof end interface - interface + interface subroutine psb_c_apply2_vect(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ type(psb_desc_type),intent(in) :: desc_data @@ -114,8 +118,8 @@ module psb_c_prec_type complex(psb_spk_),intent(inout), optional, target :: work(:) end subroutine psb_c_apply2_vect end interface - - interface + + interface subroutine psb_c_apply1_vect(prec,x,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ type(psb_desc_type),intent(in) :: desc_data @@ -126,7 +130,7 @@ module psb_c_prec_type complex(psb_spk_),intent(inout), optional, target :: work(:) end subroutine psb_c_apply1_vect end interface - + interface subroutine psb_c_apply2v(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ @@ -139,8 +143,8 @@ module psb_c_prec_type complex(psb_spk_),intent(inout), optional, target :: work(:) end subroutine psb_c_apply2v end interface - - interface + + interface subroutine psb_c_apply1v(prec,x,desc_data,info,trans) import :: psb_ipk_, psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ type(psb_desc_type),intent(in) :: desc_data @@ -150,56 +154,89 @@ module psb_c_prec_type character(len=1), optional :: trans end subroutine psb_c_apply1v end interface - + + interface + subroutine psb_ccprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_cprec_type, psb_cspmat_type, psb_desc_type, psb_spk_, & + & psb_ipk_ + class(psb_cprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_ccprecseti + subroutine psb_ccprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_cprec_type, psb_cspmat_type, psb_desc_type, psb_spk_, & + & psb_ipk_ + class(psb_cprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_ccprecsetr + subroutine psb_ccprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + import :: psb_cprec_type, psb_cspmat_type, psb_desc_type, psb_spk_, & + & psb_ipk_ + class(psb_cprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_ccprecsetc +end interface + contains subroutine psb_cfile_prec_descr(prec,iout, root) use psb_base_mod - implicit none + implicit none class(psb_cprec_type), intent(in) :: prec integer(psb_ipk_), intent(in), optional :: iout integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_) :: iout_,info - character(len=20) :: name='prec_descr' - - if (present(iout)) then + character(len=20) :: name='prec_descr' + + if (present(iout)) then iout_ = iout else - iout_ = 6 + iout_ = 6 end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") end if call prec%prec%descr(iout=iout,root=root) - + end subroutine psb_cfile_prec_descr subroutine psb_c_prec_dump(prec,info,prefix,head) - implicit none + implicit none type(psb_cprec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - ! len of prefix_ + ! len of prefix_ info = 0 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to dump a non-built preconditioner' return end if - + call prec%prec%dump(info,prefix,head) - - + + end subroutine psb_c_prec_dump subroutine psb_c_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_cprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -209,33 +246,33 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_c_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to allocate wrk to a non-built preconditioner' return end if - + call prec%prec%allocate_wrk(info,vmold=vmold,desc=desc) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_c_allocate_wrk subroutine psb_c_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_cprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -243,47 +280,47 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_c_free_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to free a non-built preconditioner' return end if - + call prec%prec%free_wrk(info) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_c_free_wrk function psb_c_is_allocated_wrk(prec) result(res) implicit none - + ! Arguments class(psb_cprec_type), intent(in) :: prec logical :: res if (.not.allocated(prec%prec)) then res = .false. - else + else res = prec%prec%is_allocated_wrk() end if - + end function psb_c_is_allocated_wrk subroutine psb_c_precfree(p,info) use psb_base_mod - implicit none + implicit none type(psb_cprec_type), intent(inout) :: p integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -303,14 +340,14 @@ contains return 9999 call psb_error_handler(err_act) - + return end subroutine psb_c_precfree subroutine psb_c_prec_free(prec,info) use psb_base_mod - implicit none + implicit none class(psb_cprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -324,7 +361,7 @@ contains me=-1 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%free(info) if (info /= psb_success_) goto 9999 deallocate(prec%prec,stat=info) @@ -343,26 +380,26 @@ contains class(psb_cprec_type), intent(in) :: prec integer(psb_epk_) :: val integer(psb_ipk_) :: i - + val = 0 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then val = val + prec%prec%sizeof() end if - + end function psb_cprec_sizeof subroutine psb_c_prec_clone(prec,precout,info) - implicit none + implicit none class(psb_cprec_type), intent(inout) :: prec class(psb_cprec_type), intent(inout) :: precout integer(psb_ipk_), intent(out) :: info info = psb_success_ call prec%free(info) - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%clone(precout%prec,info) end if - + end subroutine psb_c_prec_clone end module psb_c_prec_type diff --git a/prec/psb_d_ainv_fact_mod.f90 b/prec/psb_d_ainv_fact_mod.f90 new file mode 100644 index 00000000..8eb6fbc8 --- /dev/null +++ b/prec/psb_d_ainv_fact_mod.f90 @@ -0,0 +1,98 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from MLD2P4, original copyright below. +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 MLD2P4 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. +! +! +! +! +! File: psb_d_ainv_fact_mod.f90 +! +! Module: psb_d_ainv_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_d_ainv_solver, but not visible to the end user. +! +! +module psb_d_ainv_fact_mod + use psb_base_mod + use psb_prec_const_mod + + interface psb_ainv_fact + subroutine psb_d_ainv_bld(a,alg,fillin,thresh,wmat,d,zmat,desc,info,blck,iscale) + import psb_dspmat_type, psb_dpk_, psb_ipk_, psb_desc_type + type(psb_dspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,alg + real(psb_dpk_), intent(in) :: thresh + type(psb_dspmat_type), intent(inout) :: wmat, zmat + real(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), optional :: blck + integer(psb_ipk_), intent(in), optional :: iscale + end subroutine psb_d_ainv_bld + end interface + +end module psb_d_ainv_fact_mod diff --git a/prec/psb_d_ainv_tools_mod.f90 b/prec/psb_d_ainv_tools_mod.f90 new file mode 100644 index 00000000..7329533b --- /dev/null +++ b/prec/psb_d_ainv_tools_mod.f90 @@ -0,0 +1,132 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +! +! +! +! +module psb_d_ainv_tools_mod + + interface sp_drop + subroutine psb_d_sp_drop(idiag,nzrmax,sp_thresh,nz,iz,valz,info) + use psb_base_mod, only : psb_dpk_, psb_ipk_ + implicit none + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, nzrmax + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: iz(:) + real(psb_dpk_), intent(inout) :: valz(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_sp_drop + end interface + + interface rwclip + subroutine psb_d_rwclip(nz,ia,ja,val,imin,imax,jmin,jmax) + use psb_base_mod, only : psb_dpk_, psb_ipk_ + + implicit none + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: ia(*), ja(*) + real(psb_dpk_), intent(inout) :: val(*) + integer(psb_ipk_), intent(in) :: imin,imax,jmin,jmax + end subroutine psb_d_rwclip + end interface + + interface sparsify + subroutine psb_d_sparsify(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,info, & + & istart,iheap,ikr) + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_i_heap + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: istart + type(psb_i_heap), optional :: iheap + integer(psb_ipk_), optional :: ikr(:) + end subroutine psb_d_sparsify + subroutine psb_d_sparsify_list(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,lhead,listv,ikr,info) + use psb_base_mod, only : psb_dpk_, psb_ipk_ + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: lhead, listv(:) + integer(psb_ipk_) :: ikr(:) + end subroutine psb_d_sparsify_list + + end interface + +end module psb_d_ainv_tools_mod diff --git a/prec/psb_d_base_prec_mod.f90 b/prec/psb_d_base_prec_mod.f90 index dc39ca70..74b28f02 100644 --- a/prec/psb_d_base_prec_mod.f90 +++ b/prec/psb_d_base_prec_mod.f90 @@ -36,17 +36,18 @@ module psb_d_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_epk_,& + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_epk_, psb_ctxt_type, & & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& & psb_sizeof_ip, psb_sizeof_lp, psb_sizeof_sp, psb_sizeof_dp, & - & psb_erractionsave, psb_erractionrestore, psb_error, psb_errstatus_fatal, psb_success_,& + & psb_erractionsave, psb_erractionrestore, psb_error, & + & psb_errstatus_fatal, psb_success_,& & psb_d_base_sparse_mat, psb_dspmat_type, psb_d_csr_sparse_mat,& & psb_d_base_vect_type, psb_d_vect_type, psb_i_base_vect_type use psb_prec_const_mod type, abstract :: psb_d_base_prec_type - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt contains procedure, pass(prec) :: set_ctxt => psb_d_base_set_ctxt procedure, pass(prec) :: get_ctxt => psb_d_base_get_ctxt @@ -342,12 +343,12 @@ contains end function psb_d_base_is_allocated_wrk - subroutine psb_d_base_set_ctxt(prec,ictxt) + subroutine psb_d_base_set_ctxt(prec,ctxt) implicit none class(psb_d_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type) :: ctxt - prec%ictxt = ictxt + prec%ctxt = ctxt end subroutine psb_d_base_set_ctxt @@ -361,9 +362,9 @@ contains function psb_d_base_get_ctxt(prec) result(val) class(psb_d_base_prec_type), intent(in) :: prec - integer(psb_ipk_) :: val + type(psb_ctxt_type) :: val - val = prec%ictxt + val = prec%ctxt return end function psb_d_base_get_ctxt @@ -382,10 +383,11 @@ contains character(len=32) :: res ! character(len=32) :: frmtv - integer(psb_ipk_) :: ni, ictxt,iam,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: ni, iam, np - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) res = '' if (iam /= psb_root_) then diff --git a/prec/psb_d_biconjg_mod.F90 b/prec/psb_d_biconjg_mod.F90 new file mode 100644 index 00000000..09358744 --- /dev/null +++ b/prec/psb_d_biconjg_mod.F90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +module psb_d_biconjg_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_sparse_biconjg + module procedure psb_dsparse_biconjg + end interface + + abstract interface + subroutine psb_dsparse_biconjg_variant(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod, only : psb_d_csr_sparse_mat, psb_d_csc_sparse_mat, & + & psb_dpk_, psb_ipk_ + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + real(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dsparse_biconjg_variant + end interface + + + procedure(psb_dsparse_biconjg_variant) :: psb_dsparse_biconjg_llk,& + & psb_dsparse_biconjg_s_llk, psb_dsparse_biconjg_s_ft_llk,& + & psb_dsparse_biconjg_llk_noth, psb_dsparse_biconjg_mlk + +#if defined(HAVE_TUMA_SAINV) + procedure(psb_dsparse_biconjg_variant) :: psb_dsparse_tuma_sainv,& + & psb_dsparse_tuma_lainv +#endif + +contains + + subroutine psb_dsparse_biconjg(alg,n,acsr,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_prec_const_mod + integer(psb_ipk_), intent(in) :: alg,n + type(psb_d_csr_sparse_mat), intent(in) :: acsr + type(psb_dspmat_type), intent(out) :: z, w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + real(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_d_csc_sparse_mat) :: zcsc,wcsc + integer(psb_ipk_) :: i,j,k,nrm + integer(psb_ipk_) :: err_act + character(len=20) :: name='psb_sparse_biconjg' + integer(psb_ipk_), parameter :: variant=1 + + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (size(p) precout) - type is (psb_d_bjac_prec_type) + type is (psb_d_bjac_prec_type) call pout%set_ctxt(prec%get_ctxt()) - if (allocated(prec%av)) then + if (allocated(prec%av)) then allocate(pout%av(size(prec%av)),stat=info) - do i=1,size(prec%av) + do i=1,size(prec%av) if (info /= psb_success_) exit call prec%av(i)%clone(pout%av(i),info) enddo if (info /= psb_success_) goto 9999 end if - if (allocated(prec%dv)) then + if (allocated(prec%dv)) then allocate(pout%dv,stat=info) if (info == 0) call prec%dv%clone(pout%dv,info) end if @@ -315,7 +330,7 @@ contains subroutine psb_d_bjac_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_d_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -325,11 +340,11 @@ contains ! Local variables integer(psb_ipk_) :: err_act, i character(len=20) :: name - + info=psb_success_ name = 'psb_d_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 if (allocated(prec%wrk)) then if (size(prec%wrk)<2) then @@ -342,11 +357,11 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + if (.not.allocated(prec%wrk)) then - if (.not.present(desc)) then + if (.not.present(desc)) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="no desc?"); goto 9999 - end if + end if allocate(prec%wrk(2),stat=info) do i=1, 2 if (info == 0) call psb_geall(prec%wrk(i),desc,info) @@ -356,19 +371,19 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="allocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_d_bjac_allocate_wrk subroutine psb_d_bjac_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_d_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -377,14 +392,14 @@ contains integer(psb_ipk_) :: err_act integer(psb_ipk_) :: i character(len=20) :: name - + info=psb_success_ name = 'psb_d_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - info = psb_success_ + info = psb_success_ if (allocated(prec%wrk)) then do i=1,size(prec%wrk) if (info == 0) call prec%wrk(i)%free(info) @@ -394,29 +409,29 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_d_bjac_free_wrk function psb_d_bjac_is_allocated_wrk(prec) result(res) use psb_base_mod implicit none - + ! Arguments class(psb_d_bjac_prec_type), intent(in) :: prec logical :: res - ! In the base version we can say yes, because + ! In the base version we can say yes, because ! there is nothing to allocate res = allocated(prec%wrk) - + end function psb_d_bjac_is_allocated_wrk - + end module psb_d_bjacprec diff --git a/prec/psb_d_diagprec.f90 b/prec/psb_d_diagprec.f90 index 4bdda8bc..7ebcb6c3 100644 --- a/prec/psb_d_diagprec.f90 +++ b/prec/psb_d_diagprec.f90 @@ -171,7 +171,8 @@ contains integer(psb_ipk_) :: err_act, nrow, info character(len=20) :: name='d_diag_precdescr' - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -188,8 +189,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam diff --git a/prec/psb_d_invk_fact_mod.f90 b/prec/psb_d_invk_fact_mod.f90 new file mode 100644 index 00000000..2bd97198 --- /dev/null +++ b/prec/psb_d_invk_fact_mod.f90 @@ -0,0 +1,165 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_d_invk_fact_mod.f90 +! +! Module: psb_d_invk_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_d_invk_solver, but not visible to the end user. +! +! +module psb_d_invk_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invk_fact + subroutine psb_d_invk_bld(a,fill1, fill2,lmat,d,umat,desc,info,blck) + ! import + import psb_dspmat_type, psb_ipk_, psb_dpk_, psb_desc_type + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_dspmat_type), intent(inout) :: lmat, umat + real(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), optional :: blck + end subroutine + end interface + + ! Inner workings + interface psb_sparse_invk + subroutine psb_dsparse_invk(n,a,z,fill_in,info,inlevs) + ! Import + import psb_ipk_, psb_dspmat_type + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_dsparse_invk + end interface + + interface psb_invk_inv + subroutine psb_dinvk_inv(fill_in,i,row,rowlevs,heap,uia1,uia2,uaspk,uplevs,& + & nidx,idxs,info) + + use psb_base_mod, only : psb_dspmat_type, psb_dpk_, psb_i_heap, psb_ipk_ + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: uia1(:),uia2(:),uplevs(:) + real(psb_dpk_), intent(in) :: uaspk(:) + real(psb_dpk_), intent(inout) :: row(:) + + + end subroutine psb_dinvk_inv + end interface + + interface psb_invk_copyin + subroutine psb_d_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,& + & ktrw,trw,info,sign,inlevs) + ! Import + use psb_base_mod, only : psb_d_csr_sparse_mat, psb_d_coo_sparse_mat,& + & psb_dpk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + real(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_d_invk_copyin + end interface + + interface psb_invk_copyout + subroutine psb_d_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + use psb_base_mod, only : psb_dspmat_type, psb_dpk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + real(psb_dpk_), allocatable, intent(inout) :: uaspk(:) + real(psb_dpk_), intent(inout) :: row(:) + end subroutine psb_d_invk_copyout + end interface + +end module diff --git a/prec/psb_d_invt_fact_mod.f90 b/prec/psb_d_invt_fact_mod.f90 new file mode 100644 index 00000000..f38c1c2b --- /dev/null +++ b/prec/psb_d_invt_fact_mod.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_d_invt_fact_mod.f90 +! +! Module: psb_d_invt_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_d_invt_solver, but not visible to the end user. +! +! +module psb_d_invt_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invt_fact + subroutine psb_d_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + ! Import + import psb_dspmat_type, psb_dpk_, psb_ipk_, psb_desc_type + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_dpk_), intent(in) :: thresh + real(psb_dpk_), intent(in) :: invthresh + type(psb_dspmat_type), intent(inout) :: lmat, umat + real(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), optional :: blck + end subroutine psb_d_invt_bld + end interface + + ! Interfaces for the inner workings + + interface + subroutine psb_dsparse_invt(n,a,z,nzrmax,sp_thresh,info) + ! Import + import psb_dspmat_type, psb_dpk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dsparse_invt + end interface + + interface + subroutine psb_d_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + ! Import + import psb_d_csr_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_, & + & psb_ipk_, psb_i_heap + ! Arguments + type(psb_d_csr_sparse_mat), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(inout) :: nrmi + real(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), intent(in), optional :: sign + end subroutine psb_d_invt_copyin + end interface + + interface + subroutine psb_d_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + ! Import + import psb_dpk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_dpk_), intent(in) :: thres,nrmi + real(psb_dpk_),allocatable, intent(inout) :: val(:) + real(psb_dpk_), intent(inout) :: row(:) + end subroutine psb_d_invt_copyout + end interface + + interface psb_invt_inv + subroutine psb_d_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val, & + & nidx,idxs,info) + ! import + import psb_dpk_, psb_i_heap, psb_ipk_ + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_), intent(inout) :: row(:) + end subroutine + end interface + +contains + +end module psb_d_invt_fact_mod diff --git a/prec/psb_d_nullprec.f90 b/prec/psb_d_nullprec.f90 index 421c59ef..65214a31 100644 --- a/prec/psb_d_nullprec.f90 +++ b/prec/psb_d_nullprec.f90 @@ -170,7 +170,8 @@ contains character(len=20) :: name='d_null_precset' character(len=32) :: dprefix, frmtv integer(psb_ipk_) :: ni - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -187,8 +188,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam @@ -212,7 +213,8 @@ contains class(psb_d_null_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: iout, iam, np, ictxt, lname + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout, iam, np, lname logical :: isopen character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than @@ -220,8 +222,8 @@ contains ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/psb_d_prec_type.f90 b/prec/psb_d_prec_type.f90 index f50339a3..391023bd 100644 --- a/prec/psb_d_prec_type.f90 +++ b/prec/psb_d_prec_type.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,8 +27,8 @@ ! 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. -! -! +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Module to define PREC_DATA, !! !! structure for preconditioning. !! @@ -39,7 +39,7 @@ module psb_d_prec_type use psb_d_base_prec_mod type psb_dprec_type - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt class(psb_d_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: psb_d_apply1_vect @@ -54,6 +54,10 @@ module psb_d_prec_type procedure, pass(prec) :: build => psb_dprecbld procedure, pass(prec) :: init => psb_dprecinit procedure, pass(prec) :: descr => psb_dfile_prec_descr + procedure, pass(prec) :: cseti => psb_dcprecseti + procedure, pass(prec) :: csetc => psb_dcprecsetc + procedure, pass(prec) :: csetr => psb_dcprecsetr + generic, public :: set => cseti, csetc, csetr procedure, pass(prec) :: allocate_wrk => psb_d_allocate_wrk procedure, pass(prec) :: free_wrk => psb_d_free_wrk procedure, pass(prec) :: is_allocated_wrk => psb_d_is_allocated_wrk @@ -64,10 +68,10 @@ module psb_d_prec_type end interface interface psb_precinit - subroutine psb_dprecinit(ictxt,prec,ptype,info) - import :: psb_ipk_, psb_dprec_type + subroutine psb_dprecinit(ctxt,prec,ptype,info) + import :: psb_ipk_, psb_dprec_type, psb_ctxt_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_dprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -102,7 +106,7 @@ module psb_d_prec_type module procedure psb_dprec_sizeof end interface - interface + interface subroutine psb_d_apply2_vect(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ type(psb_desc_type),intent(in) :: desc_data @@ -114,8 +118,8 @@ module psb_d_prec_type real(psb_dpk_),intent(inout), optional, target :: work(:) end subroutine psb_d_apply2_vect end interface - - interface + + interface subroutine psb_d_apply1_vect(prec,x,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ type(psb_desc_type),intent(in) :: desc_data @@ -126,7 +130,7 @@ module psb_d_prec_type real(psb_dpk_),intent(inout), optional, target :: work(:) end subroutine psb_d_apply1_vect end interface - + interface subroutine psb_d_apply2v(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ @@ -139,8 +143,8 @@ module psb_d_prec_type real(psb_dpk_),intent(inout), optional, target :: work(:) end subroutine psb_d_apply2v end interface - - interface + + interface subroutine psb_d_apply1v(prec,x,desc_data,info,trans) import :: psb_ipk_, psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ type(psb_desc_type),intent(in) :: desc_data @@ -150,56 +154,89 @@ module psb_d_prec_type character(len=1), optional :: trans end subroutine psb_d_apply1v end interface - + + interface + subroutine psb_dcprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_dprec_type, psb_dspmat_type, psb_desc_type, psb_dpk_, & + & psb_ipk_ + class(psb_dprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_dcprecseti + subroutine psb_dcprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_dprec_type, psb_dspmat_type, psb_desc_type, psb_dpk_, & + & psb_ipk_ + class(psb_dprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_dcprecsetr + subroutine psb_dcprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + import :: psb_dprec_type, psb_dspmat_type, psb_desc_type, psb_dpk_, & + & psb_ipk_ + class(psb_dprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_dcprecsetc +end interface + contains subroutine psb_dfile_prec_descr(prec,iout, root) use psb_base_mod - implicit none + implicit none class(psb_dprec_type), intent(in) :: prec integer(psb_ipk_), intent(in), optional :: iout integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_) :: iout_,info - character(len=20) :: name='prec_descr' - - if (present(iout)) then + character(len=20) :: name='prec_descr' + + if (present(iout)) then iout_ = iout else - iout_ = 6 + iout_ = 6 end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") end if call prec%prec%descr(iout=iout,root=root) - + end subroutine psb_dfile_prec_descr subroutine psb_d_prec_dump(prec,info,prefix,head) - implicit none + implicit none type(psb_dprec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - ! len of prefix_ + ! len of prefix_ info = 0 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to dump a non-built preconditioner' return end if - + call prec%prec%dump(info,prefix,head) - - + + end subroutine psb_d_prec_dump subroutine psb_d_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_dprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -209,33 +246,33 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_d_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to allocate wrk to a non-built preconditioner' return end if - + call prec%prec%allocate_wrk(info,vmold=vmold,desc=desc) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_d_allocate_wrk subroutine psb_d_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_dprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -243,47 +280,47 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_d_free_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to free a non-built preconditioner' return end if - + call prec%prec%free_wrk(info) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_d_free_wrk function psb_d_is_allocated_wrk(prec) result(res) implicit none - + ! Arguments class(psb_dprec_type), intent(in) :: prec logical :: res if (.not.allocated(prec%prec)) then res = .false. - else + else res = prec%prec%is_allocated_wrk() end if - + end function psb_d_is_allocated_wrk subroutine psb_d_precfree(p,info) use psb_base_mod - implicit none + implicit none type(psb_dprec_type), intent(inout) :: p integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -303,14 +340,14 @@ contains return 9999 call psb_error_handler(err_act) - + return end subroutine psb_d_precfree subroutine psb_d_prec_free(prec,info) use psb_base_mod - implicit none + implicit none class(psb_dprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -324,7 +361,7 @@ contains me=-1 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%free(info) if (info /= psb_success_) goto 9999 deallocate(prec%prec,stat=info) @@ -343,26 +380,26 @@ contains class(psb_dprec_type), intent(in) :: prec integer(psb_epk_) :: val integer(psb_ipk_) :: i - + val = 0 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then val = val + prec%prec%sizeof() end if - + end function psb_dprec_sizeof subroutine psb_d_prec_clone(prec,precout,info) - implicit none + implicit none class(psb_dprec_type), intent(inout) :: prec class(psb_dprec_type), intent(inout) :: precout integer(psb_ipk_), intent(out) :: info info = psb_success_ call prec%free(info) - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%clone(precout%prec,info) end if - + end subroutine psb_d_prec_clone end module psb_d_prec_type diff --git a/prec/psb_prec_const_mod.f90 b/prec/psb_prec_const_mod.f90 index f7b32d2f..73c22e58 100644 --- a/prec/psb_prec_const_mod.f90 +++ b/prec/psb_prec_const_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,8 +27,8 @@ ! 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. -! -! +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Module to define PREC_DATA, !! !! structure for preconditioning. !! @@ -43,19 +43,23 @@ module psb_prec_const_mod ! Entries in iprcparm: preconditioner type, factorization type, ! prolongation type, restriction type, renumbering algorithm, - ! number of overlap layers, pointer to SuperLU factors, - ! levels of fill in for ILU(N), + ! number of overlap layers, pointer to SuperLU factors, + ! levels of fill in for ILU(N), integer(psb_ipk_), parameter :: psb_p_type_=1, psb_f_type_=2 integer(psb_ipk_), parameter :: psb_ilu_fill_in_=8 + integer(psb_ipk_), parameter :: psb_ilu_ialg_=9 !Renumbering. SEE BELOW integer(psb_ipk_), parameter :: psb_renum_none_=0, psb_renum_glb_=1, psb_renum_gps_=2 integer(psb_ipk_), parameter :: psb_ifpsz=10 ! Entries in rprcparm: ILU(E) epsilon, smoother omega + integer(psb_ipk_), parameter :: psb_ilu_scale_=7 integer(psb_ipk_), parameter :: psb_fact_eps_=1 - integer(psb_ipk_), parameter :: psb_rfpsz=4 - ! Factorization types: none, ILU(N), ILU(E) - integer(psb_ipk_), parameter :: psb_f_none_=0,psb_f_ilu_n_=1 - ! Fields for sparse matrices ensembles: + integer(psb_ipk_), parameter :: psb_rfpsz=8 + ! Factorization types: none, ILU(0), ILU(N), ILU(N,E) + integer(psb_ipk_), parameter :: psb_f_none_=0,psb_f_ilu_n_=1,psb_f_ilu_k_=2,psb_f_ilu_t_=3 + ! Approximate Inverse factorization type: AINV, INVT, INVK + integer(psb_ipk_), parameter :: psb_f_ainv_=4, psb_f_invt_=5, psb_f_invk_=6 + ! Fields for sparse matrices ensembles: integer(psb_ipk_), parameter :: psb_l_pr_=1, psb_u_pr_=2, psb_bp_ilu_avsz=2 integer(psb_ipk_), parameter :: psb_max_avsz=psb_bp_ilu_avsz @@ -65,11 +69,21 @@ module psb_prec_const_mod integer(psb_ipk_), parameter :: psb_ilu_scale_none_ = 0 integer(psb_ipk_), parameter :: psb_ilu_scale_maxval_ = 1 integer(psb_ipk_), parameter :: psb_ilu_scale_diag_ = 2 - integer(psb_ipk_), parameter :: psb_ilu_scale_arwsum_ = 3 + integer(psb_ipk_), parameter :: psb_ilu_scale_arwsum_ = 3 integer(psb_ipk_), parameter :: psb_ilu_scale_aclsum_ = 4 integer(psb_ipk_), parameter :: psb_ilu_scale_arcsum_ = 5 - + ! Numerical parameters relative to Approximate Inverse Preconditioners + integer, parameter :: psb_inv_fillin_ = 3 + integer, parameter :: psb_ainv_alg_ = psb_inv_fillin_ + 1 + integer, parameter :: psb_inv_thresh_ = 3 + integer, parameter :: psb_ainv_llk_ = psb_inv_thresh_ + 1 + integer, parameter :: psb_ainv_s_llk_ = psb_ainv_llk_ + 1 + integer, parameter :: psb_ainv_s_ft_llk_ = psb_ainv_s_llk_ + 1 + integer, parameter :: psb_ainv_llk_noth_ = psb_ainv_s_ft_llk_ + 1 + integer, parameter :: psb_ainv_mlk_ = psb_ainv_llk_noth_ + 1 + integer, parameter :: psb_ainv_lmx_ = psb_ainv_mlk_ + interface psb_check_def module procedure psb_icheck_def, psb_scheck_def, psb_dcheck_def @@ -87,9 +101,9 @@ contains select case(iprec) case(psb_noprec_) pr_to_str='NOPREC' - case(psb_diag_) + case(psb_diag_) pr_to_str='DIAG' - case(psb_bjac_) + case(psb_bjac_) pr_to_str='BJAC' case default pr_to_str='???' @@ -125,7 +139,7 @@ contains integer(psb_ipk_), intent(inout) :: ip integer(psb_ipk_), intent(in) :: id character(len=*), intent(in) :: name - interface + interface function is_legal(i) import :: psb_ipk_ integer(psb_ipk_), intent(in) :: i @@ -133,7 +147,7 @@ contains end function is_legal end interface - if (.not.is_legal(ip)) then + if (.not.is_legal(ip)) then write(psb_err_unit,*) 'Illegal value for ',name,' :',ip, '. defaulting to ',id ip = id end if @@ -143,7 +157,7 @@ contains real(psb_spk_), intent(inout) :: ip real(psb_spk_), intent(in) :: id character(len=*), intent(in) :: name - interface + interface function is_legal(i) import :: psb_ipk_, psb_spk_ real(psb_spk_), intent(in) :: i @@ -151,7 +165,7 @@ contains end function is_legal end interface - if (.not.is_legal(ip)) then + if (.not.is_legal(ip)) then write(psb_err_unit,*) 'Illegal value for ',name,' :',ip, '. defaulting to ',id ip = id end if @@ -161,7 +175,7 @@ contains real(psb_dpk_), intent(inout) :: ip real(psb_dpk_), intent(in) :: id character(len=*), intent(in) :: name - interface + interface function is_legal(i) import :: psb_ipk_, psb_spk_, psb_dpk_ real(psb_dpk_), intent(in) :: i @@ -169,7 +183,7 @@ contains end function is_legal end interface - if (.not.is_legal(ip)) then + if (.not.is_legal(ip)) then write(psb_err_unit,*) 'Illegal value for ',name,' :',ip, '. defaulting to ',id ip = id end if diff --git a/prec/psb_s_ainv_fact_mod.f90 b/prec/psb_s_ainv_fact_mod.f90 new file mode 100644 index 00000000..bc7f1d12 --- /dev/null +++ b/prec/psb_s_ainv_fact_mod.f90 @@ -0,0 +1,98 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from MLD2P4, original copyright below. +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 MLD2P4 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. +! +! +! +! +! File: psb_s_ainv_fact_mod.f90 +! +! Module: psb_s_ainv_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_s_ainv_solver, but not visible to the end user. +! +! +module psb_s_ainv_fact_mod + use psb_base_mod + use psb_prec_const_mod + + interface psb_ainv_fact + subroutine psb_s_ainv_bld(a,alg,fillin,thresh,wmat,d,zmat,desc,info,blck,iscale) + import psb_sspmat_type, psb_spk_, psb_ipk_, psb_desc_type + type(psb_sspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,alg + real(psb_spk_), intent(in) :: thresh + type(psb_sspmat_type), intent(inout) :: wmat, zmat + real(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: blck + integer(psb_ipk_), intent(in), optional :: iscale + end subroutine psb_s_ainv_bld + end interface + +end module psb_s_ainv_fact_mod diff --git a/prec/psb_s_ainv_tools_mod.f90 b/prec/psb_s_ainv_tools_mod.f90 new file mode 100644 index 00000000..caa50164 --- /dev/null +++ b/prec/psb_s_ainv_tools_mod.f90 @@ -0,0 +1,132 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +! +! +! +! +module psb_s_ainv_tools_mod + + interface sp_drop + subroutine psb_s_sp_drop(idiag,nzrmax,sp_thresh,nz,iz,valz,info) + use psb_base_mod, only : psb_spk_, psb_ipk_ + implicit none + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, nzrmax + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: iz(:) + real(psb_spk_), intent(inout) :: valz(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_sp_drop + end interface + + interface rwclip + subroutine psb_s_rwclip(nz,ia,ja,val,imin,imax,jmin,jmax) + use psb_base_mod, only : psb_spk_, psb_ipk_ + + implicit none + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: ia(*), ja(*) + real(psb_spk_), intent(inout) :: val(*) + integer(psb_ipk_), intent(in) :: imin,imax,jmin,jmax + end subroutine psb_s_rwclip + end interface + + interface sparsify + subroutine psb_s_sparsify(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,info, & + & istart,iheap,ikr) + use psb_base_mod, only : psb_spk_, psb_ipk_, psb_i_heap + implicit none + + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_spk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_spk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: istart + type(psb_i_heap), optional :: iheap + integer(psb_ipk_), optional :: ikr(:) + end subroutine psb_s_sparsify + subroutine psb_s_sparsify_list(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,lhead,listv,ikr,info) + use psb_base_mod, only : psb_spk_, psb_ipk_ + implicit none + + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + real(psb_spk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + real(psb_spk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: lhead, listv(:) + integer(psb_ipk_) :: ikr(:) + end subroutine psb_s_sparsify_list + + end interface + +end module psb_s_ainv_tools_mod diff --git a/prec/psb_s_base_prec_mod.f90 b/prec/psb_s_base_prec_mod.f90 index b2a89f06..e41690f0 100644 --- a/prec/psb_s_base_prec_mod.f90 +++ b/prec/psb_s_base_prec_mod.f90 @@ -36,17 +36,18 @@ module psb_s_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_spk_, psb_ipk_, psb_epk_,& + use psb_base_mod, only : psb_spk_, psb_ipk_, psb_epk_, psb_ctxt_type, & & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& & psb_sizeof_ip, psb_sizeof_lp, psb_sizeof_sp, psb_sizeof_dp, & - & psb_erractionsave, psb_erractionrestore, psb_error, psb_errstatus_fatal, psb_success_,& + & psb_erractionsave, psb_erractionrestore, psb_error, & + & psb_errstatus_fatal, psb_success_,& & psb_s_base_sparse_mat, psb_sspmat_type, psb_s_csr_sparse_mat,& & psb_s_base_vect_type, psb_s_vect_type, psb_i_base_vect_type use psb_prec_const_mod type, abstract :: psb_s_base_prec_type - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt contains procedure, pass(prec) :: set_ctxt => psb_s_base_set_ctxt procedure, pass(prec) :: get_ctxt => psb_s_base_get_ctxt @@ -342,12 +343,12 @@ contains end function psb_s_base_is_allocated_wrk - subroutine psb_s_base_set_ctxt(prec,ictxt) + subroutine psb_s_base_set_ctxt(prec,ctxt) implicit none class(psb_s_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type) :: ctxt - prec%ictxt = ictxt + prec%ctxt = ctxt end subroutine psb_s_base_set_ctxt @@ -361,9 +362,9 @@ contains function psb_s_base_get_ctxt(prec) result(val) class(psb_s_base_prec_type), intent(in) :: prec - integer(psb_ipk_) :: val + type(psb_ctxt_type) :: val - val = prec%ictxt + val = prec%ctxt return end function psb_s_base_get_ctxt @@ -382,10 +383,11 @@ contains character(len=32) :: res ! character(len=32) :: frmtv - integer(psb_ipk_) :: ni, ictxt,iam,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: ni, iam, np - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) res = '' if (iam /= psb_root_) then diff --git a/prec/psb_s_biconjg_mod.F90 b/prec/psb_s_biconjg_mod.F90 new file mode 100644 index 00000000..bc2aaefc --- /dev/null +++ b/prec/psb_s_biconjg_mod.F90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +module psb_s_biconjg_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_sparse_biconjg + module procedure psb_ssparse_biconjg + end interface + + abstract interface + subroutine psb_ssparse_biconjg_variant(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod, only : psb_s_csr_sparse_mat, psb_s_csc_sparse_mat, & + & psb_spk_, psb_ipk_ + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + real(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ssparse_biconjg_variant + end interface + + + procedure(psb_ssparse_biconjg_variant) :: psb_ssparse_biconjg_llk,& + & psb_ssparse_biconjg_s_llk, psb_ssparse_biconjg_s_ft_llk,& + & psb_ssparse_biconjg_llk_noth, psb_ssparse_biconjg_mlk + +#if defined(HAVE_TUMA_SAINV) + procedure(psb_ssparse_biconjg_variant) :: psb_ssparse_tuma_sainv,& + & psb_ssparse_tuma_lainv +#endif + +contains + + subroutine psb_ssparse_biconjg(alg,n,acsr,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_prec_const_mod + integer(psb_ipk_), intent(in) :: alg,n + type(psb_s_csr_sparse_mat), intent(in) :: acsr + type(psb_sspmat_type), intent(out) :: z, w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + real(psb_spk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_s_csc_sparse_mat) :: zcsc,wcsc + integer(psb_ipk_) :: i,j,k,nrm + integer(psb_ipk_) :: err_act + character(len=20) :: name='psb_sparse_biconjg' + integer(psb_ipk_), parameter :: variant=1 + + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (size(p) precout) - type is (psb_s_bjac_prec_type) + type is (psb_s_bjac_prec_type) call pout%set_ctxt(prec%get_ctxt()) - if (allocated(prec%av)) then + if (allocated(prec%av)) then allocate(pout%av(size(prec%av)),stat=info) - do i=1,size(prec%av) + do i=1,size(prec%av) if (info /= psb_success_) exit call prec%av(i)%clone(pout%av(i),info) enddo if (info /= psb_success_) goto 9999 end if - if (allocated(prec%dv)) then + if (allocated(prec%dv)) then allocate(pout%dv,stat=info) if (info == 0) call prec%dv%clone(pout%dv,info) end if @@ -315,7 +330,7 @@ contains subroutine psb_s_bjac_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_s_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -325,11 +340,11 @@ contains ! Local variables integer(psb_ipk_) :: err_act, i character(len=20) :: name - + info=psb_success_ name = 'psb_s_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 if (allocated(prec%wrk)) then if (size(prec%wrk)<2) then @@ -342,11 +357,11 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + if (.not.allocated(prec%wrk)) then - if (.not.present(desc)) then + if (.not.present(desc)) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="no desc?"); goto 9999 - end if + end if allocate(prec%wrk(2),stat=info) do i=1, 2 if (info == 0) call psb_geall(prec%wrk(i),desc,info) @@ -356,19 +371,19 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="allocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_s_bjac_allocate_wrk subroutine psb_s_bjac_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_s_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -377,14 +392,14 @@ contains integer(psb_ipk_) :: err_act integer(psb_ipk_) :: i character(len=20) :: name - + info=psb_success_ name = 'psb_s_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - info = psb_success_ + info = psb_success_ if (allocated(prec%wrk)) then do i=1,size(prec%wrk) if (info == 0) call prec%wrk(i)%free(info) @@ -394,29 +409,29 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_s_bjac_free_wrk function psb_s_bjac_is_allocated_wrk(prec) result(res) use psb_base_mod implicit none - + ! Arguments class(psb_s_bjac_prec_type), intent(in) :: prec logical :: res - ! In the base version we can say yes, because + ! In the base version we can say yes, because ! there is nothing to allocate res = allocated(prec%wrk) - + end function psb_s_bjac_is_allocated_wrk - + end module psb_s_bjacprec diff --git a/prec/psb_s_diagprec.f90 b/prec/psb_s_diagprec.f90 index 56c3c458..c5af4dd1 100644 --- a/prec/psb_s_diagprec.f90 +++ b/prec/psb_s_diagprec.f90 @@ -171,7 +171,8 @@ contains integer(psb_ipk_) :: err_act, nrow, info character(len=20) :: name='s_diag_precdescr' - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -188,8 +189,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam diff --git a/prec/psb_s_invk_fact_mod.f90 b/prec/psb_s_invk_fact_mod.f90 new file mode 100644 index 00000000..6b0d3553 --- /dev/null +++ b/prec/psb_s_invk_fact_mod.f90 @@ -0,0 +1,165 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_s_invk_fact_mod.f90 +! +! Module: psb_s_invk_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_s_invk_solver, but not visible to the end user. +! +! +module psb_s_invk_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invk_fact + subroutine psb_s_invk_bld(a,fill1, fill2,lmat,d,umat,desc,info,blck) + ! import + import psb_sspmat_type, psb_ipk_, psb_spk_, psb_desc_type + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_sspmat_type), intent(inout) :: lmat, umat + real(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: blck + end subroutine + end interface + + ! Inner workings + interface psb_sparse_invk + subroutine psb_ssparse_invk(n,a,z,fill_in,info,inlevs) + ! Import + import psb_ipk_, psb_sspmat_type + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_ssparse_invk + end interface + + interface psb_invk_inv + subroutine psb_sinvk_inv(fill_in,i,row,rowlevs,heap,uia1,uia2,uaspk,uplevs,& + & nidx,idxs,info) + + use psb_base_mod, only : psb_sspmat_type, psb_spk_, psb_i_heap, psb_ipk_ + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: uia1(:),uia2(:),uplevs(:) + real(psb_spk_), intent(in) :: uaspk(:) + real(psb_spk_), intent(inout) :: row(:) + + + end subroutine psb_sinvk_inv + end interface + + interface psb_invk_copyin + subroutine psb_s_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,& + & ktrw,trw,info,sign,inlevs) + ! Import + use psb_base_mod, only : psb_s_csr_sparse_mat, psb_s_coo_sparse_mat,& + & psb_spk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + real(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_s_invk_copyin + end interface + + interface psb_invk_copyout + subroutine psb_s_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + use psb_base_mod, only : psb_sspmat_type, psb_spk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + real(psb_spk_), allocatable, intent(inout) :: uaspk(:) + real(psb_spk_), intent(inout) :: row(:) + end subroutine psb_s_invk_copyout + end interface + +end module diff --git a/prec/psb_s_invt_fact_mod.f90 b/prec/psb_s_invt_fact_mod.f90 new file mode 100644 index 00000000..2c9ce38c --- /dev/null +++ b/prec/psb_s_invt_fact_mod.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_s_invt_fact_mod.f90 +! +! Module: psb_s_invt_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_s_invt_solver, but not visible to the end user. +! +! +module psb_s_invt_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invt_fact + subroutine psb_s_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + ! Import + import psb_sspmat_type, psb_spk_, psb_ipk_, psb_desc_type + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_spk_), intent(in) :: thresh + real(psb_spk_), intent(in) :: invthresh + type(psb_sspmat_type), intent(inout) :: lmat, umat + real(psb_spk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), optional :: blck + end subroutine psb_s_invt_bld + end interface + + ! Interfaces for the inner workings + + interface + subroutine psb_ssparse_invt(n,a,z,nzrmax,sp_thresh,info) + ! Import + import psb_sspmat_type, psb_spk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_sspmat_type), intent(in) :: a + type(psb_sspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_spk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ssparse_invt + end interface + + interface + subroutine psb_s_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + ! Import + import psb_s_csr_sparse_mat, psb_s_coo_sparse_mat, psb_spk_, & + & psb_ipk_, psb_i_heap + ! Arguments + type(psb_s_csr_sparse_mat), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(inout) :: nrmi + real(psb_spk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_spk_), intent(in), optional :: sign + end subroutine psb_s_invt_copyin + end interface + + interface + subroutine psb_s_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + ! Import + import psb_spk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_spk_), intent(in) :: thres,nrmi + real(psb_spk_),allocatable, intent(inout) :: val(:) + real(psb_spk_), intent(inout) :: row(:) + end subroutine psb_s_invt_copyout + end interface + + interface psb_invt_inv + subroutine psb_s_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val, & + & nidx,idxs,info) + ! import + import psb_spk_, psb_i_heap, psb_ipk_ + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_spk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: row(:) + end subroutine + end interface + +contains + +end module psb_s_invt_fact_mod diff --git a/prec/psb_s_nullprec.f90 b/prec/psb_s_nullprec.f90 index 06e31251..33b22de0 100644 --- a/prec/psb_s_nullprec.f90 +++ b/prec/psb_s_nullprec.f90 @@ -170,7 +170,8 @@ contains character(len=20) :: name='s_null_precset' character(len=32) :: dprefix, frmtv integer(psb_ipk_) :: ni - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -187,8 +188,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam @@ -212,7 +213,8 @@ contains class(psb_s_null_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: iout, iam, np, ictxt, lname + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout, iam, np, lname logical :: isopen character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than @@ -220,8 +222,8 @@ contains ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/psb_s_prec_type.f90 b/prec/psb_s_prec_type.f90 index ded50ca4..764e9109 100644 --- a/prec/psb_s_prec_type.f90 +++ b/prec/psb_s_prec_type.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,8 +27,8 @@ ! 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. -! -! +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Module to define PREC_DATA, !! !! structure for preconditioning. !! @@ -39,7 +39,7 @@ module psb_s_prec_type use psb_s_base_prec_mod type psb_sprec_type - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt class(psb_s_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: psb_s_apply1_vect @@ -54,6 +54,10 @@ module psb_s_prec_type procedure, pass(prec) :: build => psb_sprecbld procedure, pass(prec) :: init => psb_sprecinit procedure, pass(prec) :: descr => psb_sfile_prec_descr + procedure, pass(prec) :: cseti => psb_scprecseti + procedure, pass(prec) :: csetc => psb_scprecsetc + procedure, pass(prec) :: csetr => psb_scprecsetr + generic, public :: set => cseti, csetc, csetr procedure, pass(prec) :: allocate_wrk => psb_s_allocate_wrk procedure, pass(prec) :: free_wrk => psb_s_free_wrk procedure, pass(prec) :: is_allocated_wrk => psb_s_is_allocated_wrk @@ -64,10 +68,10 @@ module psb_s_prec_type end interface interface psb_precinit - subroutine psb_sprecinit(ictxt,prec,ptype,info) - import :: psb_ipk_, psb_sprec_type + subroutine psb_sprecinit(ctxt,prec,ptype,info) + import :: psb_ipk_, psb_sprec_type, psb_ctxt_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_sprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -102,7 +106,7 @@ module psb_s_prec_type module procedure psb_sprec_sizeof end interface - interface + interface subroutine psb_s_apply2_vect(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ type(psb_desc_type),intent(in) :: desc_data @@ -114,8 +118,8 @@ module psb_s_prec_type real(psb_spk_),intent(inout), optional, target :: work(:) end subroutine psb_s_apply2_vect end interface - - interface + + interface subroutine psb_s_apply1_vect(prec,x,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ type(psb_desc_type),intent(in) :: desc_data @@ -126,7 +130,7 @@ module psb_s_prec_type real(psb_spk_),intent(inout), optional, target :: work(:) end subroutine psb_s_apply1_vect end interface - + interface subroutine psb_s_apply2v(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ @@ -139,8 +143,8 @@ module psb_s_prec_type real(psb_spk_),intent(inout), optional, target :: work(:) end subroutine psb_s_apply2v end interface - - interface + + interface subroutine psb_s_apply1v(prec,x,desc_data,info,trans) import :: psb_ipk_, psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ type(psb_desc_type),intent(in) :: desc_data @@ -150,56 +154,89 @@ module psb_s_prec_type character(len=1), optional :: trans end subroutine psb_s_apply1v end interface - + + interface + subroutine psb_scprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_sprec_type, psb_sspmat_type, psb_desc_type, psb_spk_, & + & psb_ipk_ + class(psb_sprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_scprecseti + subroutine psb_scprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_sprec_type, psb_sspmat_type, psb_desc_type, psb_spk_, & + & psb_ipk_ + class(psb_sprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_spk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_scprecsetr + subroutine psb_scprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + import :: psb_sprec_type, psb_sspmat_type, psb_desc_type, psb_spk_, & + & psb_ipk_ + class(psb_sprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_scprecsetc +end interface + contains subroutine psb_sfile_prec_descr(prec,iout, root) use psb_base_mod - implicit none + implicit none class(psb_sprec_type), intent(in) :: prec integer(psb_ipk_), intent(in), optional :: iout integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_) :: iout_,info - character(len=20) :: name='prec_descr' - - if (present(iout)) then + character(len=20) :: name='prec_descr' + + if (present(iout)) then iout_ = iout else - iout_ = 6 + iout_ = 6 end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") end if call prec%prec%descr(iout=iout,root=root) - + end subroutine psb_sfile_prec_descr subroutine psb_s_prec_dump(prec,info,prefix,head) - implicit none + implicit none type(psb_sprec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - ! len of prefix_ + ! len of prefix_ info = 0 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to dump a non-built preconditioner' return end if - + call prec%prec%dump(info,prefix,head) - - + + end subroutine psb_s_prec_dump subroutine psb_s_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_sprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -209,33 +246,33 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_s_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to allocate wrk to a non-built preconditioner' return end if - + call prec%prec%allocate_wrk(info,vmold=vmold,desc=desc) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_s_allocate_wrk subroutine psb_s_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_sprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -243,47 +280,47 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_s_free_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to free a non-built preconditioner' return end if - + call prec%prec%free_wrk(info) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_s_free_wrk function psb_s_is_allocated_wrk(prec) result(res) implicit none - + ! Arguments class(psb_sprec_type), intent(in) :: prec logical :: res if (.not.allocated(prec%prec)) then res = .false. - else + else res = prec%prec%is_allocated_wrk() end if - + end function psb_s_is_allocated_wrk subroutine psb_s_precfree(p,info) use psb_base_mod - implicit none + implicit none type(psb_sprec_type), intent(inout) :: p integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -303,14 +340,14 @@ contains return 9999 call psb_error_handler(err_act) - + return end subroutine psb_s_precfree subroutine psb_s_prec_free(prec,info) use psb_base_mod - implicit none + implicit none class(psb_sprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -324,7 +361,7 @@ contains me=-1 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%free(info) if (info /= psb_success_) goto 9999 deallocate(prec%prec,stat=info) @@ -343,26 +380,26 @@ contains class(psb_sprec_type), intent(in) :: prec integer(psb_epk_) :: val integer(psb_ipk_) :: i - + val = 0 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then val = val + prec%prec%sizeof() end if - + end function psb_sprec_sizeof subroutine psb_s_prec_clone(prec,precout,info) - implicit none + implicit none class(psb_sprec_type), intent(inout) :: prec class(psb_sprec_type), intent(inout) :: precout integer(psb_ipk_), intent(out) :: info info = psb_success_ call prec%free(info) - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%clone(precout%prec,info) end if - + end subroutine psb_s_prec_clone end module psb_s_prec_type diff --git a/prec/psb_z_ainv_fact_mod.f90 b/prec/psb_z_ainv_fact_mod.f90 new file mode 100644 index 00000000..490fe132 --- /dev/null +++ b/prec/psb_z_ainv_fact_mod.f90 @@ -0,0 +1,98 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from MLD2P4, original copyright below. +! +! +! MLD2P4 version 2.2 +! MultiLevel Domain Decomposition Parallel Preconditioners Package +! based on PSBLAS (Parallel Sparse BLAS version 3.5) +! +! (C) Copyright 2008-2018 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Daniela di Serafino +! +! 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 MLD2P4 group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 MLD2P4 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. +! +! +! +! +! File: psb_z_ainv_fact_mod.f90 +! +! Module: psb_z_ainv_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_z_ainv_solver, but not visible to the end user. +! +! +module psb_z_ainv_fact_mod + use psb_base_mod + use psb_prec_const_mod + + interface psb_ainv_fact + subroutine psb_z_ainv_bld(a,alg,fillin,thresh,wmat,d,zmat,desc,info,blck,iscale) + import psb_zspmat_type, psb_dpk_, psb_ipk_, psb_desc_type + type(psb_zspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,alg + real(psb_dpk_), intent(in) :: thresh + type(psb_zspmat_type), intent(inout) :: wmat, zmat + complex(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), optional :: blck + integer(psb_ipk_), intent(in), optional :: iscale + end subroutine psb_z_ainv_bld + end interface + +end module psb_z_ainv_fact_mod diff --git a/prec/psb_z_ainv_tools_mod.f90 b/prec/psb_z_ainv_tools_mod.f90 new file mode 100644 index 00000000..f611c2a7 --- /dev/null +++ b/prec/psb_z_ainv_tools_mod.f90 @@ -0,0 +1,132 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +! +! +! +! +module psb_z_ainv_tools_mod + + interface sp_drop + subroutine psb_z_sp_drop(idiag,nzrmax,sp_thresh,nz,iz,valz,info) + use psb_base_mod, only : psb_dpk_, psb_ipk_ + implicit none + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, nzrmax + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: iz(:) + complex(psb_dpk_), intent(inout) :: valz(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_sp_drop + end interface + + interface rwclip + subroutine psb_z_rwclip(nz,ia,ja,val,imin,imax,jmin,jmax) + use psb_base_mod, only : psb_dpk_, psb_ipk_ + + implicit none + integer(psb_ipk_), intent(inout) :: nz + integer(psb_ipk_), intent(inout) :: ia(*), ja(*) + complex(psb_dpk_), intent(inout) :: val(*) + integer(psb_ipk_), intent(in) :: imin,imax,jmin,jmax + end subroutine psb_z_rwclip + end interface + + interface sparsify + subroutine psb_z_sparsify(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,info, & + & istart,iheap,ikr) + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_i_heap + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + complex(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: istart + type(psb_i_heap), optional :: iheap + integer(psb_ipk_), optional :: ikr(:) + end subroutine psb_z_sparsify + subroutine psb_z_sparsify_list(idiag,nzrmax,sp_thresh,n,zw,nz,iz,valz,lhead,listv,ikr,info) + use psb_base_mod, only : psb_dpk_, psb_ipk_ + implicit none + + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(in) :: idiag, n, nzrmax + complex(psb_dpk_), intent(inout) :: zw(:) + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), intent(out) :: iz(:) + complex(psb_dpk_), intent(out) :: valz(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: lhead, listv(:) + integer(psb_ipk_) :: ikr(:) + end subroutine psb_z_sparsify_list + + end interface + +end module psb_z_ainv_tools_mod diff --git a/prec/psb_z_base_prec_mod.f90 b/prec/psb_z_base_prec_mod.f90 index a1e832f4..740d3219 100644 --- a/prec/psb_z_base_prec_mod.f90 +++ b/prec/psb_z_base_prec_mod.f90 @@ -36,17 +36,18 @@ module psb_z_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_epk_,& + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_epk_, psb_ctxt_type, & & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& & psb_sizeof_ip, psb_sizeof_lp, psb_sizeof_sp, psb_sizeof_dp, & - & psb_erractionsave, psb_erractionrestore, psb_error, psb_errstatus_fatal, psb_success_,& + & psb_erractionsave, psb_erractionrestore, psb_error, & + & psb_errstatus_fatal, psb_success_,& & psb_z_base_sparse_mat, psb_zspmat_type, psb_z_csr_sparse_mat,& & psb_z_base_vect_type, psb_z_vect_type, psb_i_base_vect_type use psb_prec_const_mod type, abstract :: psb_z_base_prec_type - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt contains procedure, pass(prec) :: set_ctxt => psb_z_base_set_ctxt procedure, pass(prec) :: get_ctxt => psb_z_base_get_ctxt @@ -342,12 +343,12 @@ contains end function psb_z_base_is_allocated_wrk - subroutine psb_z_base_set_ctxt(prec,ictxt) + subroutine psb_z_base_set_ctxt(prec,ctxt) implicit none class(psb_z_base_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type) :: ctxt - prec%ictxt = ictxt + prec%ctxt = ctxt end subroutine psb_z_base_set_ctxt @@ -361,9 +362,9 @@ contains function psb_z_base_get_ctxt(prec) result(val) class(psb_z_base_prec_type), intent(in) :: prec - integer(psb_ipk_) :: val + type(psb_ctxt_type) :: val - val = prec%ictxt + val = prec%ctxt return end function psb_z_base_get_ctxt @@ -382,10 +383,11 @@ contains character(len=32) :: res ! character(len=32) :: frmtv - integer(psb_ipk_) :: ni, ictxt,iam,np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: ni, iam, np - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) res = '' if (iam /= psb_root_) then diff --git a/prec/psb_z_biconjg_mod.F90 b/prec/psb_z_biconjg_mod.F90 new file mode 100644 index 00000000..b40485e7 --- /dev/null +++ b/prec/psb_z_biconjg_mod.F90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG-AINV, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +module psb_z_biconjg_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_sparse_biconjg + module procedure psb_zsparse_biconjg + end interface + + abstract interface + subroutine psb_zsparse_biconjg_variant(n,a,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod, only : psb_z_csr_sparse_mat, psb_z_csc_sparse_mat, & + & psb_dpk_, psb_ipk_ + ! + implicit none + integer(psb_ipk_), intent(in) :: n + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_csc_sparse_mat), intent(inout) :: z,w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + complex(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zsparse_biconjg_variant + end interface + + + procedure(psb_zsparse_biconjg_variant) :: psb_zsparse_biconjg_llk,& + & psb_zsparse_biconjg_s_llk, psb_zsparse_biconjg_s_ft_llk,& + & psb_zsparse_biconjg_llk_noth, psb_zsparse_biconjg_mlk + +#if defined(HAVE_TUMA_SAINV) + procedure(psb_zsparse_biconjg_variant) :: psb_zsparse_tuma_sainv,& + & psb_zsparse_tuma_lainv +#endif + +contains + + subroutine psb_zsparse_biconjg(alg,n,acsr,p,z,w,nzrmax,sp_thresh,info) + use psb_base_mod + use psb_prec_const_mod + integer(psb_ipk_), intent(in) :: alg,n + type(psb_z_csr_sparse_mat), intent(in) :: acsr + type(psb_zspmat_type), intent(out) :: z, w + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + complex(psb_dpk_), intent(out) :: p(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_z_csc_sparse_mat) :: zcsc,wcsc + integer(psb_ipk_) :: i,j,k,nrm + integer(psb_ipk_) :: err_act + character(len=20) :: name='psb_sparse_biconjg' + integer(psb_ipk_), parameter :: variant=1 + + + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_; goto 9999 + end if + + if (size(p) precout) - type is (psb_z_bjac_prec_type) + type is (psb_z_bjac_prec_type) call pout%set_ctxt(prec%get_ctxt()) - if (allocated(prec%av)) then + if (allocated(prec%av)) then allocate(pout%av(size(prec%av)),stat=info) - do i=1,size(prec%av) + do i=1,size(prec%av) if (info /= psb_success_) exit call prec%av(i)%clone(pout%av(i),info) enddo if (info /= psb_success_) goto 9999 end if - if (allocated(prec%dv)) then + if (allocated(prec%dv)) then allocate(pout%dv,stat=info) if (info == 0) call prec%dv%clone(pout%dv,info) end if @@ -315,7 +330,7 @@ contains subroutine psb_z_bjac_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_z_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -325,11 +340,11 @@ contains ! Local variables integer(psb_ipk_) :: err_act, i character(len=20) :: name - + info=psb_success_ name = 'psb_z_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 if (allocated(prec%wrk)) then if (size(prec%wrk)<2) then @@ -342,11 +357,11 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + if (.not.allocated(prec%wrk)) then - if (.not.present(desc)) then + if (.not.present(desc)) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="no desc?"); goto 9999 - end if + end if allocate(prec%wrk(2),stat=info) do i=1, 2 if (info == 0) call psb_geall(prec%wrk(i),desc,info) @@ -356,19 +371,19 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="allocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_z_bjac_allocate_wrk subroutine psb_z_bjac_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_z_bjac_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -377,14 +392,14 @@ contains integer(psb_ipk_) :: err_act integer(psb_ipk_) :: i character(len=20) :: name - + info=psb_success_ name = 'psb_z_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - info = psb_success_ + info = psb_success_ if (allocated(prec%wrk)) then do i=1,size(prec%wrk) if (info == 0) call prec%wrk(i)%free(info) @@ -394,29 +409,29 @@ contains if (info /= 0) then info = psb_err_internal_error_; call psb_errpush(info,name,a_err="deallocate"); goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_z_bjac_free_wrk function psb_z_bjac_is_allocated_wrk(prec) result(res) use psb_base_mod implicit none - + ! Arguments class(psb_z_bjac_prec_type), intent(in) :: prec logical :: res - ! In the base version we can say yes, because + ! In the base version we can say yes, because ! there is nothing to allocate res = allocated(prec%wrk) - + end function psb_z_bjac_is_allocated_wrk - + end module psb_z_bjacprec diff --git a/prec/psb_z_diagprec.f90 b/prec/psb_z_diagprec.f90 index 5201989d..f62f4c03 100644 --- a/prec/psb_z_diagprec.f90 +++ b/prec/psb_z_diagprec.f90 @@ -171,7 +171,8 @@ contains integer(psb_ipk_) :: err_act, nrow, info character(len=20) :: name='z_diag_precdescr' - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -188,8 +189,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam diff --git a/prec/psb_z_invk_fact_mod.f90 b/prec/psb_z_invk_fact_mod.f90 new file mode 100644 index 00000000..0a1e5faf --- /dev/null +++ b/prec/psb_z_invk_fact_mod.f90 @@ -0,0 +1,165 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_z_invk_fact_mod.f90 +! +! Module: psb_z_invk_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_z_invk_solver, but not visible to the end user. +! +! +module psb_z_invk_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invk_fact + subroutine psb_z_invk_bld(a,fill1, fill2,lmat,d,umat,desc,info,blck) + ! import + import psb_zspmat_type, psb_ipk_, psb_dpk_, psb_desc_type + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fill1, fill2 + type(psb_zspmat_type), intent(inout) :: lmat, umat + complex(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), optional :: blck + end subroutine + end interface + + ! Inner workings + interface psb_sparse_invk + subroutine psb_zsparse_invk(n,a,z,fill_in,info,inlevs) + ! Import + import psb_ipk_, psb_zspmat_type + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: fill_in + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_zsparse_invk + end interface + + interface psb_invk_inv + subroutine psb_zinvk_inv(fill_in,i,row,rowlevs,heap,uia1,uia2,uaspk,uplevs,& + & nidx,idxs,info) + + use psb_base_mod, only : psb_zspmat_type, psb_dpk_, psb_i_heap, psb_ipk_ + implicit none + + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i, fill_in + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: uia1(:),uia2(:),uplevs(:) + complex(psb_dpk_), intent(in) :: uaspk(:) + complex(psb_dpk_), intent(inout) :: row(:) + + + end subroutine psb_zinvk_inv + end interface + + interface psb_invk_copyin + subroutine psb_z_invk_copyin(i,m,a,jmin,jmax,row,rowlevs,heap,& + & ktrw,trw,info,sign,inlevs) + ! Import + use psb_base_mod, only : psb_z_csr_sparse_mat, psb_z_coo_sparse_mat,& + & psb_dpk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i,m,jmin,jmax + integer(psb_ipk_), intent(inout) :: ktrw,info + integer(psb_ipk_), intent(inout) :: rowlevs(:) + complex(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), optional, intent(in) :: sign + integer(psb_ipk_), intent(in), optional :: inlevs(:) + end subroutine psb_z_invk_copyin + end interface + + interface psb_invk_copyout + subroutine psb_z_invk_copyout(fill_in,i,m,row,rowlevs,nidx,idxs,& + & l2,uia1,uia2,uaspk,info) + use psb_base_mod, only : psb_zspmat_type, psb_dpk_, psb_i_heap, psb_ipk_ + implicit none + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in, i, m, nidx + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), intent(inout) :: rowlevs(:), idxs(:) + integer(psb_ipk_), allocatable, intent(inout) :: uia1(:), uia2(:) + complex(psb_dpk_), allocatable, intent(inout) :: uaspk(:) + complex(psb_dpk_), intent(inout) :: row(:) + end subroutine psb_z_invk_copyout + end interface + +end module diff --git a/prec/psb_z_invt_fact_mod.f90 b/prec/psb_z_invt_fact_mod.f90 new file mode 100644 index 00000000..1cdf32f4 --- /dev/null +++ b/prec/psb_z_invt_fact_mod.f90 @@ -0,0 +1,168 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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 PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific 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 PSBLAS 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. +! +! Moved here from AMG4PSBLAS, original copyright below. +! +! +! AMG-AINV: Approximate Inverse plugin for +! AMG4PSBLAS version 1.0 +! +! (C) Copyright 2020 +! +! Salvatore Filippone University of Rome Tor Vergata +! +! 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 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. +! +! +! File: psb_z_invt_fact_mod.f90 +! +! Module: psb_z_invt_fact_mod +! +! This module defines some interfaces used internally by the implementation of +! psb_z_invt_solver, but not visible to the end user. +! +! +module psb_z_invt_fact_mod + + use psb_base_mod + use psb_prec_const_mod + + interface psb_invt_fact + subroutine psb_z_invt_bld(a,fillin,invfill,thresh,invthresh,& + & lmat,d,umat,desc,info,blck) + ! Import + import psb_zspmat_type, psb_dpk_, psb_ipk_, psb_desc_type + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(in) :: fillin,invfill + real(psb_dpk_), intent(in) :: thresh + real(psb_dpk_), intent(in) :: invthresh + type(psb_zspmat_type), intent(inout) :: lmat, umat + complex(psb_dpk_), allocatable :: d(:) + Type(psb_desc_type), Intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), optional :: blck + end subroutine psb_z_invt_bld + end interface + + ! Interfaces for the inner workings + + interface + subroutine psb_zsparse_invt(n,a,z,nzrmax,sp_thresh,info) + ! Import + import psb_zspmat_type, psb_dpk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: n + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(inout) :: z + integer(psb_ipk_), intent(in) :: nzrmax + real(psb_dpk_), intent(in) :: sp_thresh + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zsparse_invt + end interface + + interface + subroutine psb_z_invt_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,& + & irwt,ktrw,trw,info,sign) + ! Import + import psb_z_csr_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_, & + & psb_ipk_, psb_i_heap + ! Arguments + type(psb_z_csr_sparse_mat), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(inout) :: trw + integer(psb_ipk_), intent(in) :: i, m,jmin,jmax,jd + integer(psb_ipk_), intent(inout) :: ktrw,nlw,nup,jmaxup,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(inout) :: nrmi + complex(psb_dpk_), intent(inout) :: row(:) + type(psb_i_heap), intent(inout) :: heap + real(psb_dpk_), intent(in), optional :: sign + end subroutine psb_z_invt_copyin + end interface + + interface + subroutine psb_z_invt_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & + & nidx,idxs,l2,ja,irp,val,info) + ! Import + import psb_dpk_, psb_ipk_ + ! Arguments + integer(psb_ipk_), intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup + integer(psb_ipk_), intent(in) :: idxs(:) + integer(psb_ipk_), intent(inout) :: l2, info + integer(psb_ipk_), allocatable, intent(inout) :: ja(:),irp(:) + real(psb_dpk_), intent(in) :: thres,nrmi + complex(psb_dpk_),allocatable, intent(inout) :: val(:) + complex(psb_dpk_), intent(inout) :: row(:) + end subroutine psb_z_invt_copyout + end interface + + interface psb_invt_inv + subroutine psb_z_invt_inv(thres,i,nrmi,row,heap,irwt,ja,irp,val, & + & nidx,idxs,info) + ! import + import psb_dpk_, psb_i_heap, psb_ipk_ + ! Arguments + type(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(in) :: i + integer(psb_ipk_), intent(inout) :: nidx,info + integer(psb_ipk_), intent(inout) :: irwt(:) + real(psb_dpk_), intent(in) :: thres,nrmi + integer(psb_ipk_), allocatable, intent(inout) :: idxs(:) + integer(psb_ipk_), intent(in) :: ja(:),irp(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_), intent(inout) :: row(:) + end subroutine + end interface + +contains + +end module psb_z_invt_fact_mod diff --git a/prec/psb_z_nullprec.f90 b/prec/psb_z_nullprec.f90 index 7c0d26ff..4981ef21 100644 --- a/prec/psb_z_nullprec.f90 +++ b/prec/psb_z_nullprec.f90 @@ -170,7 +170,8 @@ contains character(len=20) :: name='z_null_precset' character(len=32) :: dprefix, frmtv integer(psb_ipk_) :: ni - integer(psb_ipk_) :: iout_, ictxt, iam, np, root_ + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout_, iam, np, root_ call psb_erractionsave(err_act) @@ -187,8 +188,8 @@ contains root_ = psb_root_ end if - ictxt = prec%ictxt - call psb_info(ictxt,iam,np) + ctxt = prec%ctxt + call psb_info(ctxt,iam,np) if (root_ == -1) root_ = iam @@ -212,7 +213,8 @@ contains class(psb_z_null_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - integer(psb_ipk_) :: iout, iam, np, ictxt, lname + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iout, iam, np, lname logical :: isopen character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than @@ -220,8 +222,8 @@ contains ! len of prefix_ info = 0 - ictxt = prec%get_ctxt() - call psb_info(ictxt,iam,np) + ctxt = prec%get_ctxt() + call psb_info(ctxt,iam,np) if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) diff --git a/prec/psb_z_prec_type.f90 b/prec/psb_z_prec_type.f90 index 8b1a8f4b..f40e8004 100644 --- a/prec/psb_z_prec_type.f90 +++ b/prec/psb_z_prec_type.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,8 +27,8 @@ ! 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. -! -! +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Module to define PREC_DATA, !! !! structure for preconditioning. !! @@ -39,7 +39,7 @@ module psb_z_prec_type use psb_z_base_prec_mod type psb_zprec_type - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt class(psb_z_base_prec_type), allocatable :: prec contains procedure, pass(prec) :: psb_z_apply1_vect @@ -54,6 +54,10 @@ module psb_z_prec_type procedure, pass(prec) :: build => psb_zprecbld procedure, pass(prec) :: init => psb_zprecinit procedure, pass(prec) :: descr => psb_zfile_prec_descr + procedure, pass(prec) :: cseti => psb_zcprecseti + procedure, pass(prec) :: csetc => psb_zcprecsetc + procedure, pass(prec) :: csetr => psb_zcprecsetr + generic, public :: set => cseti, csetc, csetr procedure, pass(prec) :: allocate_wrk => psb_z_allocate_wrk procedure, pass(prec) :: free_wrk => psb_z_free_wrk procedure, pass(prec) :: is_allocated_wrk => psb_z_is_allocated_wrk @@ -64,10 +68,10 @@ module psb_z_prec_type end interface interface psb_precinit - subroutine psb_zprecinit(ictxt,prec,ptype,info) - import :: psb_ipk_, psb_zprec_type + subroutine psb_zprecinit(ctxt,prec,ptype,info) + import :: psb_ipk_, psb_zprec_type, psb_ctxt_type implicit none - integer(psb_ipk_), intent(in) :: ictxt + type(psb_ctxt_type), intent(in) :: ctxt class(psb_zprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info @@ -102,7 +106,7 @@ module psb_z_prec_type module procedure psb_zprec_sizeof end interface - interface + interface subroutine psb_z_apply2_vect(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ type(psb_desc_type),intent(in) :: desc_data @@ -114,8 +118,8 @@ module psb_z_prec_type complex(psb_dpk_),intent(inout), optional, target :: work(:) end subroutine psb_z_apply2_vect end interface - - interface + + interface subroutine psb_z_apply1_vect(prec,x,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ type(psb_desc_type),intent(in) :: desc_data @@ -126,7 +130,7 @@ module psb_z_prec_type complex(psb_dpk_),intent(inout), optional, target :: work(:) end subroutine psb_z_apply1_vect end interface - + interface subroutine psb_z_apply2v(prec,x,y,desc_data,info,trans,work) import :: psb_ipk_, psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ @@ -139,8 +143,8 @@ module psb_z_prec_type complex(psb_dpk_),intent(inout), optional, target :: work(:) end subroutine psb_z_apply2v end interface - - interface + + interface subroutine psb_z_apply1v(prec,x,desc_data,info,trans) import :: psb_ipk_, psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ type(psb_desc_type),intent(in) :: desc_data @@ -150,56 +154,89 @@ module psb_z_prec_type character(len=1), optional :: trans end subroutine psb_z_apply1v end interface - + + interface + subroutine psb_zcprecseti(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_zprec_type, psb_zspmat_type, psb_desc_type, psb_dpk_, & + & psb_ipk_ + class(psb_zprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_zcprecseti + subroutine psb_zcprecsetr(prec,what,val,info,ilev,ilmax,pos,idx) + import :: psb_zprec_type, psb_zspmat_type, psb_desc_type, psb_dpk_, & + & psb_ipk_ + class(psb_zprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_zcprecsetr + subroutine psb_zcprecsetc(prec,what,string,info,ilev,ilmax,pos,idx) + import :: psb_zprec_type, psb_zspmat_type, psb_desc_type, psb_dpk_, & + & psb_ipk_ + class(psb_zprec_type), intent(inout) :: prec + character(len=*), intent(in) :: what + character(len=*), intent(in) :: string + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev,ilmax,idx + character(len=*), optional, intent(in) :: pos + end subroutine psb_zcprecsetc +end interface + contains subroutine psb_zfile_prec_descr(prec,iout, root) use psb_base_mod - implicit none + implicit none class(psb_zprec_type), intent(in) :: prec integer(psb_ipk_), intent(in), optional :: iout integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_) :: iout_,info - character(len=20) :: name='prec_descr' - - if (present(iout)) then + character(len=20) :: name='prec_descr' + + if (present(iout)) then iout_ = iout else - iout_ = 6 + iout_ = 6 end if - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") end if call prec%prec%descr(iout=iout,root=root) - + end subroutine psb_zfile_prec_descr subroutine psb_z_prec_dump(prec,info,prefix,head) - implicit none + implicit none type(psb_zprec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix,head - ! len of prefix_ + ! len of prefix_ info = 0 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to dump a non-built preconditioner' return end if - + call prec%prec%dump(info,prefix,head) - - + + end subroutine psb_z_prec_dump subroutine psb_z_allocate_wrk(prec,info,vmold,desc) use psb_base_mod implicit none - + ! Arguments class(psb_zprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -209,33 +246,33 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_z_allocate_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to allocate wrk to a non-built preconditioner' return end if - + call prec%prec%allocate_wrk(info,vmold=vmold,desc=desc) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_z_allocate_wrk subroutine psb_z_free_wrk(prec,info) use psb_base_mod implicit none - + ! Arguments class(psb_zprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info @@ -243,47 +280,47 @@ contains ! Local variables integer(psb_ipk_) :: err_act character(len=20) :: name - + info=psb_success_ name = 'psb_z_free_wrk' call psb_erractionsave(err_act) - + if (psb_get_errstatus().ne.0) goto 9999 - if (.not.allocated(prec%prec)) then + if (.not.allocated(prec%prec)) then info = -1 write(psb_err_unit,*) 'Trying to free a non-built preconditioner' return end if - + call prec%prec%free_wrk(info) - + call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return - + end subroutine psb_z_free_wrk function psb_z_is_allocated_wrk(prec) result(res) implicit none - + ! Arguments class(psb_zprec_type), intent(in) :: prec logical :: res if (.not.allocated(prec%prec)) then res = .false. - else + else res = prec%prec%is_allocated_wrk() end if - + end function psb_z_is_allocated_wrk subroutine psb_z_precfree(p,info) use psb_base_mod - implicit none + implicit none type(psb_zprec_type), intent(inout) :: p integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -303,14 +340,14 @@ contains return 9999 call psb_error_handler(err_act) - + return end subroutine psb_z_precfree subroutine psb_z_prec_free(prec,info) use psb_base_mod - implicit none + implicit none class(psb_zprec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i @@ -324,7 +361,7 @@ contains me=-1 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%free(info) if (info /= psb_success_) goto 9999 deallocate(prec%prec,stat=info) @@ -343,26 +380,26 @@ contains class(psb_zprec_type), intent(in) :: prec integer(psb_epk_) :: val integer(psb_ipk_) :: i - + val = 0 - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then val = val + prec%prec%sizeof() end if - + end function psb_zprec_sizeof subroutine psb_z_prec_clone(prec,precout,info) - implicit none + implicit none class(psb_zprec_type), intent(inout) :: prec class(psb_zprec_type), intent(inout) :: precout integer(psb_ipk_), intent(out) :: info info = psb_success_ call prec%free(info) - if (allocated(prec%prec)) then + if (allocated(prec%prec)) then call prec%prec%clone(precout%prec,info) end if - + end subroutine psb_z_prec_clone end module psb_z_prec_type diff --git a/test/cdasb/psb_d_pde3d.f90 b/test/cdasb/psb_d_pde3d.f90 index c14f8446..f554bd8a 100644 --- a/test/cdasb/psb_d_pde3d.f90 +++ b/test/cdasb/psb_d_pde3d.f90 @@ -168,7 +168,7 @@ contains ! subroutine to allocate and fill in the coefficient matrix and ! the rhs. ! - subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,info,& + subroutine psb_d_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod @@ -192,7 +192,8 @@ contains type(psb_dspmat_type) :: a type(psb_d_vect_type) :: xv,bv type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info character(len=*) :: afmt procedure(d_func_3d), optional :: f class(psb_d_base_sparse_mat), optional :: amold @@ -235,7 +236,7 @@ contains name = 'create_matrix' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) call psb_cd_set_large_threshold(1000) call psb_cd_set_maxspace(10000) @@ -282,12 +283,12 @@ contains end if nt = nr - call psb_sum(ictxt,nt) + call psb_sum(ctxt,nt) if (nt /= m) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if @@ -295,7 +296,7 @@ contains ! First example of use of CDALL: specify for each process a number of ! contiguous rows ! - call psb_cdall(ictxt,desc_a,info,nl=nr) + call psb_cdall(ctxt,desc_a,info,nl=nr) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -306,15 +307,15 @@ contains if (size(iv) /= m) then write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if else write(psb_err_unit,*) iam, 'Initialization error: IV not present' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if @@ -322,7 +323,7 @@ contains ! Second example of use of CDALL: specify for each row the ! process that owns it ! - call psb_cdall(ictxt,desc_a,info,vg=iv) + call psb_cdall(ctxt,desc_a,info,vg=iv) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -364,15 +365,15 @@ contains write(psb_err_unit,*) iam,iamx,iamy,iamz, 'Initialization error: NR vs NLR ',& & nr,nlr,mynx,myny,mynz info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) end if ! ! Third example of use of CDALL: specify for each process ! the set of global indices it owns. ! - call psb_cdall(ictxt,desc_a,info,vl=myidx) + call psb_cdall(ctxt,desc_a,info,vl=myidx) block @@ -419,8 +420,8 @@ contains case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end select @@ -430,7 +431,7 @@ contains if (info == psb_success_) call psb_geall(xv,desc_a,info) if (info == psb_success_) call psb_geall(bv,desc_a,info) - call psb_barrier(ictxt) + call psb_barrier(ctxt) talc = psb_wtime()-t0 if (info /= psb_success_) then @@ -456,7 +457,7 @@ contains ! loop over rows belonging to current process in a block ! distribution. - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do ii=1, nlr,nb ib = min(nb,nlr-ii+1) @@ -557,11 +558,11 @@ contains deallocate(val,irow,icol) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() if (info == psb_success_) then if (present(amold)) then @@ -570,7 +571,7 @@ contains call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.' @@ -586,13 +587,13 @@ contains goto 9999 end if tasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) ttot = psb_wtime() - t0 - call psb_amx(ictxt,talc) - call psb_amx(ictxt,tgen) - call psb_amx(ictxt,tasb) - call psb_amx(ictxt,ttot) + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) if(iam == psb_root_) then tmpfmt = a%get_fmt() write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& @@ -607,7 +608,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_d_gen_pde3d @@ -641,7 +642,8 @@ program psb_d_pde3d ! dense vectors type(psb_d_vect_type) :: xxv,bv ! parallel environment - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart @@ -656,12 +658,12 @@ program psb_d_pde3d info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif if(psb_errstatus_fatal()) goto 9999 @@ -677,15 +679,15 @@ program psb_d_pde3d ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) + call get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) - call psb_barrier(ictxt) + call psb_gen_pde3d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -710,10 +712,10 @@ program psb_d_pde3d goto 9999 end if - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop @@ -721,15 +723,15 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - integer(psb_ipk_) :: ictxt + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) + type(psb_ctxt_type) :: ctxt character(len=*) :: kmethd, ptype, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == 0) then if (command_argument_count()>0) then @@ -738,7 +740,7 @@ contains open(inp_unit,file=filename,action='read',iostat=info) if (info /= 0) then write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ictxt) + call psb_abort(ctxt) stop else write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' @@ -799,7 +801,7 @@ contains else ! wrong number of parameter, print an error message and exit call pr_usage(izero) - call psb_abort(ictxt) + call psb_abort(ctxt) stop 1 endif if (inp_unit /= psb_inp_unit) then @@ -808,15 +810,15 @@ contains end if ! broadcast parameters to all processors - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,idim) - call psb_bcast(ictxt,ipart) - call psb_bcast(ictxt,istopc) - call psb_bcast(ictxt,itmax) - call psb_bcast(ictxt,itrace) - call psb_bcast(ictxt,irst) + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,idim) + call psb_bcast(ctxt,ipart) + call psb_bcast(ctxt,istopc) + call psb_bcast(ctxt,itmax) + call psb_bcast(ctxt,itrace) + call psb_bcast(ctxt,irst) return diff --git a/test/fileread/getp.f90 b/test/fileread/getp.f90 index e9ddf7d2..82bef762 100644 --- a/test/fileread/getp.f90 +++ b/test/fileread/getp.f90 @@ -38,10 +38,10 @@ contains ! ! Get iteration parameters from the command line ! - subroutine get_dparms(ictxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,part,& + subroutine get_dparms(ctxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,part,& & afmt,istopc,itmax,itrace,irst,eps) use psb_base_mod - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt character(len=2) :: filefmt character(len=40) :: kmethd, mtrx_file, rhs_file, ptype character(len=20) :: part @@ -53,7 +53,7 @@ contains integer(psb_ipk_) :: inparms(40), ip, inp_unit character(len=1024) :: filename - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (iam == 0) then if (command_argument_count()>0) then call get_command_argument(1,filename) @@ -61,7 +61,7 @@ contains open(inp_unit,file=filename,action='read',iostat=info) if (info /= 0) then write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ictxt) + call psb_abort(ctxt) stop else write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' @@ -81,13 +81,13 @@ contains read(inp_unit,*) part - call psb_bcast(ictxt,mtrx_file) - call psb_bcast(ictxt,rhs_file) - call psb_bcast(ictxt,filefmt) - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,part) + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,rhs_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,part) if (ip >= 7) then read(inp_unit,*) istopc @@ -118,8 +118,8 @@ contains inparms(2) = itmax inparms(3) = itrace inparms(4) = irst - call psb_bcast(ictxt,inparms(1:4)) - call psb_bcast(ictxt,eps) + call psb_bcast(ctxt,inparms(1:4)) + call psb_bcast(ctxt,eps) write(psb_out_unit,'("Solving matrix : ",a)') mtrx_file write(psb_out_unit,'("Number of processors : ",i3)') np @@ -131,7 +131,7 @@ contains write(psb_out_unit,'(" ")') else write(psb_err_unit,*) 'Wrong format for input file' - call psb_abort(ictxt) + call psb_abort(ctxt) stop 1 end if if (inp_unit /= psb_inp_unit) then @@ -139,29 +139,29 @@ contains end if else ! Receive Parameters - call psb_bcast(ictxt,mtrx_file) - call psb_bcast(ictxt,rhs_file) - call psb_bcast(ictxt,filefmt) - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,part) + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,rhs_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,part) - call psb_bcast(ictxt,inparms(1:4)) + call psb_bcast(ctxt,inparms(1:4)) istopc = inparms(1) itmax = inparms(2) itrace = inparms(3) irst = inparms(4) - call psb_bcast(ictxt,eps) + call psb_bcast(ctxt,eps) end if end subroutine get_dparms - subroutine get_sparms(ictxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,part,& + subroutine get_sparms(ctxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,part,& & afmt,istopc,itmax,itrace,irst,eps) use psb_base_mod - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt character(len=2) :: filefmt character(len=40) :: kmethd, mtrx_file, rhs_file, ptype character(len=20) :: part @@ -173,7 +173,7 @@ contains integer(psb_ipk_) :: inparms(40), ip, inp_unit character(len=1024) :: filename - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if (iam == 0) then if (command_argument_count()>0) then call get_command_argument(1,filename) @@ -181,7 +181,7 @@ contains open(inp_unit,file=filename,action='read',iostat=info) if (info /= 0) then write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ictxt) + call psb_abort(ctxt) stop else write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' @@ -201,13 +201,13 @@ contains read(inp_unit,*) ipart - call psb_bcast(ictxt,mtrx_file) - call psb_bcast(ictxt,rhs_file) - call psb_bcast(ictxt,filefmt) - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,part) + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,rhs_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,part) if (ip >= 7) then read(inp_unit,*) istopc @@ -238,8 +238,8 @@ contains inparms(2) = itmax inparms(3) = itrace inparms(4) = irst - call psb_bcast(ictxt,inparms(1:4)) - call psb_bcast(ictxt,eps) + call psb_bcast(ctxt,inparms(1:4)) + call psb_bcast(ctxt,eps) write(psb_out_unit,'("Solving matrix : ",a)') mtrx_file write(psb_out_unit,'("Number of processors : ",i3)') np @@ -251,7 +251,7 @@ contains write(psb_out_unit,'(" ")') else write(psb_err_unit,*) 'Wrong format for input file' - call psb_abort(ictxt) + call psb_abort(ctxt) stop 1 end if if (inp_unit /= psb_inp_unit) then @@ -259,20 +259,20 @@ contains end if else ! Receive Parameters - call psb_bcast(ictxt,mtrx_file) - call psb_bcast(ictxt,rhs_file) - call psb_bcast(ictxt,filefmt) - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,part) + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,rhs_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,part) - call psb_bcast(ictxt,inparms(1:4)) + call psb_bcast(ctxt,inparms(1:4)) istopc = inparms(1) itmax = inparms(2) itrace = inparms(3) irst = inparms(4) - call psb_bcast(ictxt,eps) + call psb_bcast(ctxt,eps) end if diff --git a/test/fileread/psb_cf_sample.f90 b/test/fileread/psb_cf_sample.f90 index d340c90d..d1d620e0 100644 --- a/test/fileread/psb_cf_sample.f90 +++ b/test/fileread/psb_cf_sample.f90 @@ -56,7 +56,8 @@ program psb_cf_sample ! communications data structure type(psb_desc_type):: desc_a - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np integer(psb_lpk_) :: lnp ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& @@ -81,12 +82,12 @@ program psb_cf_sample character(len=40) :: fname, fnout - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif @@ -105,10 +106,10 @@ program psb_cf_sample ! ! get parameters ! - call get_parms(ictxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& + call get_parms(ctxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& & part,afmt,istopc,itmax,itrace,irst,eps) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 @@ -136,11 +137,11 @@ program psb_cf_sample end select if (info /= psb_success_) then write(psb_err_unit,*) 'Error while reading input matrix ' - call psb_abort(ictxt) + call psb_abort(ctxt) end if m_problem = aux_a%get_nrows() - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) ! At this point aux_b may still be unallocated if (size(aux_b,dim=1) == m_problem) then @@ -165,7 +166,7 @@ program psb_cf_sample endif else - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) end if @@ -173,7 +174,7 @@ program psb_cf_sample select case(psb_toupper(part)) case('BLOCK') if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) case('GRAPH') if (iam == psb_root_) then @@ -185,14 +186,14 @@ program psb_cf_sample call build_mtpart(aux_a,lnp) endif - call psb_barrier(ictxt) - call distr_mtpart(psb_root_,ictxt) + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) call getv_mtpart(ivg) - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) case default if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) end select call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_) @@ -205,7 +206,7 @@ program psb_cf_sample t2 = psb_wtime() - t1 - call psb_amx(ictxt, t2) + call psb_amx(ctxt, t2) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -215,7 +216,7 @@ program psb_cf_sample ! - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) ! building the preconditioner t1 = psb_wtime() @@ -227,7 +228,7 @@ program psb_cf_sample end if - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if(iam == psb_root_) then write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec @@ -235,14 +236,14 @@ program psb_cf_sample end if iparm = 0 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,& & istop=istopc,irst=irst) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) call psb_geaxpby(cone,b_col,czero,r_col,desc_a,info) call psb_spmm(-cone,a,x_col,cone,r_col,desc_a,info) resmx = psb_genrm2(r_col,desc_a,info) @@ -251,9 +252,9 @@ program psb_cf_sample amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then call prec%descr() write(psb_out_unit,'("Matrix: ",a)')mtrx_file @@ -303,10 +304,10 @@ program psb_cf_sample call psb_spfree(a, desc_a,info) call prec%free(info) call psb_cdfree(desc_a,info) - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop end program psb_cf_sample diff --git a/test/fileread/psb_df_sample.f90 b/test/fileread/psb_df_sample.f90 index d0665723..c67a07ca 100644 --- a/test/fileread/psb_df_sample.f90 +++ b/test/fileread/psb_df_sample.f90 @@ -56,7 +56,8 @@ program psb_df_sample ! communications data structure type(psb_desc_type):: desc_a - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np integer(psb_lpk_) :: lnp ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& @@ -81,12 +82,12 @@ program psb_df_sample character(len=40) :: fname, fnout - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif @@ -105,10 +106,10 @@ program psb_df_sample ! ! get parameters ! - call get_parms(ictxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& + call get_parms(ctxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& & part,afmt,istopc,itmax,itrace,irst,eps) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 @@ -136,11 +137,11 @@ program psb_df_sample end select if (info /= psb_success_) then write(psb_err_unit,*) 'Error while reading input matrix ' - call psb_abort(ictxt) + call psb_abort(ctxt) end if m_problem = aux_a%get_nrows() - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) ! At this point aux_b may still be unallocated if (size(aux_b,dim=1) == m_problem) then @@ -165,7 +166,7 @@ program psb_df_sample endif else - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) end if @@ -173,7 +174,7 @@ program psb_df_sample select case(psb_toupper(part)) case('BLOCK') if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) case('GRAPH') if (iam == psb_root_) then @@ -185,14 +186,14 @@ program psb_df_sample call build_mtpart(aux_a,lnp) endif - call psb_barrier(ictxt) - call distr_mtpart(psb_root_,ictxt) + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) call getv_mtpart(ivg) - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) case default if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) end select call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_) @@ -205,7 +206,7 @@ program psb_df_sample t2 = psb_wtime() - t1 - call psb_amx(ictxt, t2) + call psb_amx(ctxt, t2) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -215,7 +216,7 @@ program psb_df_sample ! - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) ! building the preconditioner t1 = psb_wtime() @@ -227,7 +228,7 @@ program psb_df_sample end if - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if(iam == psb_root_) then write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec @@ -236,14 +237,14 @@ program psb_df_sample cond = dzero iparm = 0 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,& & istop=istopc,irst=irst,cond=cond) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) call psb_geaxpby(done,b_col,dzero,r_col,desc_a,info) call psb_spmm(-done,a,x_col,done,r_col,desc_a,info) resmx = psb_genrm2(r_col,desc_a,info) @@ -252,9 +253,9 @@ program psb_df_sample amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then call prec%descr() write(psb_out_unit,'("Matrix: ",a)')mtrx_file @@ -305,10 +306,10 @@ program psb_df_sample call psb_spfree(a, desc_a,info) call prec%free(info) call psb_cdfree(desc_a,info) - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop end program psb_df_sample diff --git a/test/fileread/psb_sf_sample.f90 b/test/fileread/psb_sf_sample.f90 index 2801c178..c86f5f4d 100644 --- a/test/fileread/psb_sf_sample.f90 +++ b/test/fileread/psb_sf_sample.f90 @@ -56,7 +56,8 @@ program psb_sf_sample ! communications data structure type(psb_desc_type):: desc_a - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np integer(psb_lpk_) :: lnp ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& @@ -81,12 +82,12 @@ program psb_sf_sample character(len=40) :: fname, fnout - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif @@ -105,10 +106,10 @@ program psb_sf_sample ! ! get parameters ! - call get_parms(ictxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& + call get_parms(ctxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& & part,afmt,istopc,itmax,itrace,irst,eps) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 @@ -136,11 +137,11 @@ program psb_sf_sample end select if (info /= psb_success_) then write(psb_err_unit,*) 'Error while reading input matrix ' - call psb_abort(ictxt) + call psb_abort(ctxt) end if m_problem = aux_a%get_nrows() - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) ! At this point aux_b may still be unallocated if (size(aux_b,dim=1) == m_problem) then @@ -165,7 +166,7 @@ program psb_sf_sample endif else - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) end if @@ -173,7 +174,7 @@ program psb_sf_sample select case(psb_toupper(part)) case('BLOCK') if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) case('GRAPH') if (iam == psb_root_) then @@ -185,14 +186,14 @@ program psb_sf_sample call build_mtpart(aux_a,lnp) endif - call psb_barrier(ictxt) - call distr_mtpart(psb_root_,ictxt) + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) call getv_mtpart(ivg) - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) case default if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) end select call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_) @@ -205,7 +206,7 @@ program psb_sf_sample t2 = psb_wtime() - t1 - call psb_amx(ictxt, t2) + call psb_amx(ctxt, t2) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -215,7 +216,7 @@ program psb_sf_sample ! - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) ! building the preconditioner t1 = psb_wtime() @@ -227,7 +228,7 @@ program psb_sf_sample end if - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if(iam == psb_root_) then write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec @@ -236,14 +237,14 @@ program psb_sf_sample cond = szero iparm = 0 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,& & istop=istopc,irst=irst,cond=cond) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) call psb_geaxpby(sone,b_col,szero,r_col,desc_a,info) call psb_spmm(-sone,a,x_col,sone,r_col,desc_a,info) resmx = psb_genrm2(r_col,desc_a,info) @@ -252,9 +253,9 @@ program psb_sf_sample amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then call prec%descr() write(psb_out_unit,'("Matrix: ",a)')mtrx_file @@ -305,10 +306,10 @@ program psb_sf_sample call psb_spfree(a, desc_a,info) call prec%free(info) call psb_cdfree(desc_a,info) - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop end program psb_sf_sample diff --git a/test/fileread/psb_zf_sample.f90 b/test/fileread/psb_zf_sample.f90 index c327a80b..18d61022 100644 --- a/test/fileread/psb_zf_sample.f90 +++ b/test/fileread/psb_zf_sample.f90 @@ -56,7 +56,8 @@ program psb_zf_sample ! communications data structure type(psb_desc_type):: desc_a - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np integer(psb_lpk_) :: lnp ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& @@ -81,12 +82,12 @@ program psb_zf_sample character(len=40) :: fname, fnout - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif @@ -105,10 +106,10 @@ program psb_zf_sample ! ! get parameters ! - call get_parms(ictxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& + call get_parms(ctxt,mtrx_file,rhs_file,filefmt,kmethd,ptype,& & part,afmt,istopc,itmax,itrace,irst,eps) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 @@ -136,11 +137,11 @@ program psb_zf_sample end select if (info /= psb_success_) then write(psb_err_unit,*) 'Error while reading input matrix ' - call psb_abort(ictxt) + call psb_abort(ctxt) end if m_problem = aux_a%get_nrows() - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) ! At this point aux_b may still be unallocated if (size(aux_b,dim=1) == m_problem) then @@ -165,7 +166,7 @@ program psb_zf_sample endif else - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) end if @@ -173,7 +174,7 @@ program psb_zf_sample select case(psb_toupper(part)) case('BLOCK') if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) case('GRAPH') if (iam == psb_root_) then @@ -185,14 +186,14 @@ program psb_zf_sample call build_mtpart(aux_a,lnp) endif - call psb_barrier(ictxt) - call distr_mtpart(psb_root_,ictxt) + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) call getv_mtpart(ivg) - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) case default if (iam == psb_root_) write(psb_out_unit,'("Partition type: block")') - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,parts=part_block) end select call psb_scatter(b_col_glob,b_col,desc_a,info,root=psb_root_) @@ -205,7 +206,7 @@ program psb_zf_sample t2 = psb_wtime() - t1 - call psb_amx(ictxt, t2) + call psb_amx(ctxt, t2) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -215,7 +216,7 @@ program psb_zf_sample ! - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) ! building the preconditioner t1 = psb_wtime() @@ -227,7 +228,7 @@ program psb_zf_sample end if - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if(iam == psb_root_) then write(psb_out_unit,'("Preconditioner time: ",es12.5)')tprec @@ -235,14 +236,14 @@ program psb_zf_sample end if iparm = 0 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_krylov(kmethd,a,prec,b_col,x_col,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,& & istop=istopc,irst=irst) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) call psb_geaxpby(zone,b_col,zzero,r_col,desc_a,info) call psb_spmm(-zone,a,x_col,zone,r_col,desc_a,info) resmx = psb_genrm2(r_col,desc_a,info) @@ -251,9 +252,9 @@ program psb_zf_sample amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then call prec%descr() write(psb_out_unit,'("Matrix: ",a)')mtrx_file @@ -303,10 +304,10 @@ program psb_zf_sample call psb_spfree(a, desc_a,info) call prec%free(info) call psb_cdfree(desc_a,info) - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop end program psb_zf_sample diff --git a/test/fileread/runs/dfs.inp b/test/fileread/runs/dfs.inp index 22ac2034..3c6a3050 100644 --- a/test/fileread/runs/dfs.inp +++ b/test/fileread/runs/dfs.inp @@ -5,7 +5,7 @@ MM File format: MM: Matrix Market HB: Harwell-Boeing. BiCGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG BJAC Preconditioner NONE DIAG BJAC CSR Storage format CSR COO JAD -BLOCK PART: Partition method BLOCK GRAPH +GRAPH PART: Partition method BLOCK GRAPH 2 ISTOPC 00500 ITMAX -1 ITRACE diff --git a/test/hello/hello.f90 b/test/hello/hello.f90 index 2a07dba3..9f28e211 100644 --- a/test/hello/hello.f90 +++ b/test/hello/hello.f90 @@ -1,7 +1,8 @@ program hello use psb_base_mod implicit none - integer(psb_ipk_) :: iam, np, icontxt, ip, jp, idummy + type(psb_ctxt_type) :: icontxt + integer(psb_ipk_) :: iam, np, ip, jp, idummy call psb_init(icontxt) call psb_info(icontxt,iam,np) diff --git a/test/hello/pingpong.f90 b/test/hello/pingpong.f90 index b6a53c2f..ba0cbb77 100644 --- a/test/hello/pingpong.f90 +++ b/test/hello/pingpong.f90 @@ -1,7 +1,8 @@ program pingpong use psb_base_mod implicit none - integer(psb_ipk_) :: iam, np, icontxt, ip, jp, idummy + type(psb_ctxt_type) :: icontxt + integer(psb_ipk_) :: iam, np, ip, jp, idummy integer(psb_ipk_), parameter :: nmax=2**16 integer(psb_ipk_) :: i,j,k,n real(psb_dpk_) :: v(nmax) diff --git a/test/kernel/d_file_spmv.f90 b/test/kernel/d_file_spmv.f90 index bc4bb38d..ec48a68d 100644 --- a/test/kernel/d_file_spmv.f90 +++ b/test/kernel/d_file_spmv.f90 @@ -51,7 +51,8 @@ program d_file_spmv ! communications data structure type(psb_desc_type):: desc_a - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,& @@ -76,12 +77,12 @@ program d_file_spmv integer(psb_ipk_), allocatable :: ivg(:), ipv(:) - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif @@ -100,12 +101,12 @@ program d_file_spmv read(psb_inp_unit,*) filefmt read(psb_inp_unit,*) ipart end if - call psb_bcast(ictxt,mtrx_file) - call psb_bcast(ictxt,filefmt) - call psb_bcast(ictxt,ipart) + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,ipart) rhs_file = 'NONE' afmt = 'CSR' - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 @@ -133,11 +134,11 @@ program d_file_spmv end select if (info /= psb_success_) then write(psb_err_unit,*) 'Error while reading input matrix ' - call psb_abort(ictxt) + call psb_abort(ctxt) end if m_problem = aux_a%get_nrows() - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) ! At this point aux_b may still be unallocated if (psb_size(aux_b,dim=1)==m_problem) then @@ -161,7 +162,7 @@ program d_file_spmv else - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) b_col_glob =>aux_b(:,1) end if @@ -169,14 +170,14 @@ program d_file_spmv ! switch over different partition types write(psb_out_unit,'("Number of processors : ",i0)')np if (ipart == 0) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (iam==psb_root_) write(psb_out_unit,'("Partition type: block")') allocate(ivg(m_problem),ipv(np)) do i=1,m_problem call part_block(i,m_problem,np,ipv,nv) ivg(i) = ipv(1) enddo - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) else if (ipart == 2) then if (iam==psb_root_) then @@ -186,14 +187,14 @@ program d_file_spmv call build_mtpart(aux_a,np) endif - call psb_barrier(ictxt) - call distr_mtpart(psb_root_,ictxt) + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) call getv_mtpart(ivg) - call psb_matdist(aux_a, a, ictxt, desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,vg=ivg) else if (iam==psb_root_) write(psb_out_unit,'("Partition type: default block")') - call psb_matdist(aux_a, a, ictxt, desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,parts=part_block) end if @@ -206,7 +207,7 @@ program d_file_spmv t2 = psb_wtime() - t1 - call psb_amx(ictxt, t2) + call psb_amx(ctxt, t2) if (iam==psb_root_) then write(psb_out_unit,'(" ")') @@ -215,32 +216,32 @@ program d_file_spmv end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do i=1,times call psb_spmm(done,a,x_col,dzero,b_col,desc_a,info,'n') end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) ! FIXME: cache flush needed here - call psb_barrier(ictxt) + call psb_barrier(ctxt) tt1 = psb_wtime() do i=1,times call psb_spmm(done,a,x_col,dzero,b_col,desc_a,info,'t') end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) tt2 = psb_wtime() - tt1 - call psb_amx(ictxt,tt2) + call psb_amx(ctxt,tt2) nr = desc_a%get_global_rows() annz = a%get_nzeros() amatsize = psb_sizeof(a) descsize = psb_sizeof(desc_a) - call psb_sum(ictxt,annz) - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) + call psb_sum(ctxt,annz) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) if (iam==psb_root_) then flops = 2.d0*times*annz @@ -279,10 +280,10 @@ program d_file_spmv call psb_gefree(x_col, desc_a,info) call psb_spfree(a, desc_a,info) call psb_cdfree(desc_a,info) - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop diff --git a/test/kernel/pdgenspmv.f90 b/test/kernel/pdgenspmv.f90 index 1a59902f..e96736a8 100644 --- a/test/kernel/pdgenspmv.f90 +++ b/test/kernel/pdgenspmv.f90 @@ -141,7 +141,7 @@ contains ! subroutine to allocate and fill in the coefficient matrix and ! the rhs. ! - subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,info,& + subroutine psb_d_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod @@ -165,7 +165,8 @@ contains type(psb_dspmat_type) :: a type(psb_d_vect_type) :: xv,bv type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info character(len=*) :: afmt procedure(d_func_3d), optional :: f class(psb_d_base_sparse_mat), optional :: amold @@ -207,7 +208,7 @@ contains name = 'create_matrix' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (present(f)) then @@ -253,12 +254,12 @@ contains end if nt = nr - call psb_sum(ictxt,nt) + call psb_sum(ctxt,nt) if (nt /= m) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if @@ -266,7 +267,7 @@ contains ! First example of use of CDALL: specify for each process a number of ! contiguous rows ! - call psb_cdall(ictxt,desc_a,info,nl=nr) + call psb_cdall(ctxt,desc_a,info,nl=nr) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -277,15 +278,15 @@ contains if (size(iv) /= m) then write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if else write(psb_err_unit,*) iam, 'Initialization error: IV not present' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if @@ -293,7 +294,7 @@ contains ! Second example of use of CDALL: specify for each row the ! process that owns it ! - call psb_cdall(ictxt,desc_a,info,vg=iv) + call psb_cdall(ctxt,desc_a,info,vg=iv) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -335,21 +336,21 @@ contains write(psb_err_unit,*) iam,iamx,iamy,iamz, 'Initialization error: NR vs NLR ',& & nr,nlr,mynx,myny,mynz info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) end if ! ! Third example of use of CDALL: specify for each process ! the set of global indices it owns. ! - call psb_cdall(ictxt,desc_a,info,vl=myidx) + call psb_cdall(ctxt,desc_a,info,vl=myidx) case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end select @@ -359,7 +360,7 @@ contains if (info == psb_success_) call psb_geall(xv,desc_a,info) if (info == psb_success_) call psb_geall(bv,desc_a,info) - call psb_barrier(ictxt) + call psb_barrier(ctxt) talc = psb_wtime()-t0 if (info /= psb_success_) then @@ -385,7 +386,7 @@ contains ! loop over rows belonging to current process in a block ! distribution. - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do ii=1, nlr,nb ib = min(nb,nlr-ii+1) @@ -486,11 +487,11 @@ contains deallocate(val,irow,icol) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() if (info == psb_success_) then if (present(amold)) then @@ -499,7 +500,7 @@ contains call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.' @@ -515,13 +516,13 @@ contains goto 9999 end if tasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) ttot = psb_wtime() - t0 - call psb_amx(ictxt,talc) - call psb_amx(ictxt,tgen) - call psb_amx(ictxt,tasb) - call psb_amx(ictxt,ttot) + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) if(iam == psb_root_) then tmpfmt = a%get_fmt() write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& @@ -536,7 +537,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_d_gen_pde3d @@ -567,7 +568,8 @@ program pdgenspmv type(psb_d_vect_type) :: xv,bv, vtst real(psb_dpk_), allocatable :: tst(:) ! blacs parameters - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, nr, ipart @@ -583,12 +585,12 @@ program pdgenspmv info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif if(psb_get_errstatus() /= 0) goto 9999 @@ -604,15 +606,15 @@ program pdgenspmv ! ! get parameters ! - call get_parms(ictxt,afmt,idim) + call get_parms(ctxt,afmt,idim) ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - call psb_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,info) - call psb_barrier(ictxt) + call psb_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -625,7 +627,7 @@ program pdgenspmv call xv%set(done) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() ! ! Perform Ax multiple times to compute average performance @@ -633,12 +635,12 @@ program pdgenspmv do i=1,times call psb_spmm(done,a,xv,dzero,bv,desc_a,info,'n') end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) ! FIXME: cache flush needed here - call psb_barrier(ictxt) + call psb_barrier(ctxt) tt1 = psb_wtime() ! ! Perform A^Tx multiple times to compute average performance @@ -646,18 +648,18 @@ program pdgenspmv do i=1,times call psb_spmm(done,a,xv,dzero,bv,desc_a,info,'t') end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) tt2 = psb_wtime() - tt1 - call psb_amx(ictxt,tt2) + call psb_amx(ctxt,tt2) - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) nr = desc_a%get_global_rows() annz = a%get_nzeros() amatsize = a%sizeof() descsize = psb_sizeof(desc_a) - call psb_sum(ictxt,annz) - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) + call psb_sum(ctxt,annz) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) if (iam == psb_root_) then flops = 2.d0*times*annz @@ -708,10 +710,10 @@ program pdgenspmv goto 9999 end if - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop @@ -719,21 +721,21 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,afmt,idim) - integer(psb_ipk_) :: ictxt + subroutine get_parms(ctxt,afmt,idim) + type(psb_ctxt_type) :: ctxt character(len=*) :: afmt integer(psb_ipk_) :: idim integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: intbuf(10), ip - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == 0) then read(psb_inp_unit,*) afmt read(psb_inp_unit,*) idim endif - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,idim) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,idim) if (iam == 0) then write(psb_out_unit,'("Testing matrix : ell1")') diff --git a/test/kernel/s_file_spmv.f90 b/test/kernel/s_file_spmv.f90 index 68decacd..0f75518e 100644 --- a/test/kernel/s_file_spmv.f90 +++ b/test/kernel/s_file_spmv.f90 @@ -50,7 +50,8 @@ program s_file_spmv ! communications data structure type(psb_desc_type):: desc_a - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,& @@ -75,12 +76,12 @@ program s_file_spmv integer(psb_ipk_), allocatable :: ivg(:), ipv(:) - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif @@ -99,12 +100,12 @@ program s_file_spmv read(psb_inp_unit,*) filefmt read(psb_inp_unit,*) ipart end if - call psb_bcast(ictxt,mtrx_file) - call psb_bcast(ictxt,filefmt) - call psb_bcast(ictxt,ipart) + call psb_bcast(ctxt,mtrx_file) + call psb_bcast(ctxt,filefmt) + call psb_bcast(ctxt,ipart) rhs_file = 'NONE' afmt = 'CSR' - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 @@ -132,11 +133,11 @@ program s_file_spmv end select if (info /= psb_success_) then write(psb_err_unit,*) 'Error while reading input matrix ' - call psb_abort(ictxt) + call psb_abort(ctxt) end if m_problem = aux_a%get_nrows() - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) ! At this point aux_b may still be unallocated if (psb_size(aux_b,dim=1)==m_problem) then @@ -160,7 +161,7 @@ program s_file_spmv else - call psb_bcast(ictxt,m_problem) + call psb_bcast(ctxt,m_problem) b_col_glob =>aux_b(:,1) end if @@ -168,14 +169,14 @@ program s_file_spmv ! switch over different partition types write(psb_out_unit,'("Number of processors : ",i0)')np if (ipart == 0) then - call psb_barrier(ictxt) + call psb_barrier(ctxt) if (iam==psb_root_) write(psb_out_unit,'("Partition type: block")') allocate(ivg(m_problem),ipv(np)) do i=1,m_problem call part_block(i,m_problem,np,ipv,nv) ivg(i) = ipv(1) enddo - call psb_matdist(aux_a, a, ictxt,desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt,desc_a,info,fmt=afmt,vg=ivg) else if (ipart == 2) then if (iam==psb_root_) then @@ -185,14 +186,14 @@ program s_file_spmv call build_mtpart(aux_a,np) endif - call psb_barrier(ictxt) - call distr_mtpart(psb_root_,ictxt) + call psb_barrier(ctxt) + call distr_mtpart(psb_root_,ctxt) call getv_mtpart(ivg) - call psb_matdist(aux_a, a, ictxt, desc_a,info,fmt=afmt,vg=ivg) + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,vg=ivg) else if (iam==psb_root_) write(psb_out_unit,'("Partition type: default block")') - call psb_matdist(aux_a, a, ictxt, desc_a,info,fmt=afmt,parts=part_block) + call psb_matdist(aux_a, a, ctxt, desc_a,info,fmt=afmt,parts=part_block) end if call psb_geall(x_col,desc_a,info) @@ -204,7 +205,7 @@ program s_file_spmv t2 = psb_wtime() - t1 - call psb_amx(ictxt, t2) + call psb_amx(ctxt, t2) if (iam==psb_root_) then write(psb_out_unit,'(" ")') @@ -213,32 +214,32 @@ program s_file_spmv end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do i=1,times call psb_spmm(sone,a,x_col,szero,b_col,desc_a,info,'n') end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) ! FIXME: cache flush needed here - call psb_barrier(ictxt) + call psb_barrier(ctxt) tt1 = psb_wtime() do i=1,times call psb_spmm(sone,a,x_col,szero,b_col,desc_a,info,'t') end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) tt2 = psb_wtime() - tt1 - call psb_amx(ictxt,tt2) + call psb_amx(ctxt,tt2) nr = desc_a%get_global_rows() annz = a%get_nzeros() amatsize = psb_sizeof(a) descsize = psb_sizeof(desc_a) - call psb_sum(ictxt,annz) - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) + call psb_sum(ctxt,annz) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) if (iam==psb_root_) then flops = 2.d0*times*annz @@ -277,10 +278,10 @@ program s_file_spmv call psb_spfree(a, desc_a,info) call psb_cdfree(desc_a,info) - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop diff --git a/test/kernel/vecoperation.f90 b/test/kernel/vecoperation.f90 index 0b73ff15..3860a3c3 100644 --- a/test/kernel/vecoperation.f90 +++ b/test/kernel/vecoperation.f90 @@ -34,7 +34,7 @@ module unittestvector_mod use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_desc_type,& - & psb_dspmat_type, psb_d_vect_type, dzero,& + & psb_dspmat_type, psb_d_vect_type, dzero, psb_ctxt_type,& & psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type interface psb_gen_const @@ -43,14 +43,14 @@ module unittestvector_mod contains - function psb_check_ans(v,val,ictxt) result(ans) + function psb_check_ans(v,val,ctxt) result(ans) use psb_base_mod implicit none type(psb_d_vect_type) :: v real(psb_dpk_) :: val - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt logical :: ans ! Local variables @@ -58,14 +58,14 @@ contains real(psb_dpk_) :: check real(psb_dpk_), allocatable :: va(:) - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) va = v%get_vect() va = va - val; check = maxval(va); - call psb_sum(ictxt,check) + call psb_sum(ctxt,check) if(check == 0.d0) then ans = .true. @@ -77,14 +77,15 @@ contains ! ! subroutine to fill a vector with constant entries ! - subroutine psb_d_gen_const(v,val,idim,ictxt,desc_a,info) + subroutine psb_d_gen_const(v,val,idim,ctxt,desc_a,info) use psb_base_mod implicit none type(psb_d_vect_type) :: v type(psb_desc_type) :: desc_a integer(psb_lpk_) :: idim - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info real(psb_dpk_) :: val ! Local variables @@ -101,7 +102,7 @@ contains name = 'create_constant_vector' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) n = idim*np ! The global dimension is the number of process times ! the input size @@ -111,16 +112,16 @@ contains nr = max(0,min(nt,n-(iam*nt))) nt = nr - call psb_sum(ictxt,nt) + call psb_sum(ctxt,nt) if (nt /= n) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,n info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if ! Allocate the descriptor with simple minded data distribution - call psb_cdall(ictxt,desc_a,info,nl=nr) + call psb_cdall(ctxt,desc_a,info,nl=nr) ! Allocate the vector on the recently build descriptor if (info == psb_success_) call psb_geall(v,desc_a,info) ! Check that allocation has gone good @@ -155,7 +156,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_d_gen_const @@ -184,7 +185,8 @@ program vecoperation ! vector type(psb_d_vect_type) :: x,y,z ! blacs parameters - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! auxiliary parameters integer(psb_ipk_) :: info character(len=20) :: name,ch_err,readinput @@ -195,11 +197,11 @@ program vecoperation real(psb_dpk_) :: zt(1) info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then - call psb_exit(ictxt) ! This should not happen, but just in case + call psb_exit(ctxt) ! This should not happen, but just in case stop endif if(psb_get_errstatus() /= 0) goto 9999 @@ -227,112 +229,112 @@ program vecoperation if (iam == psb_root_) write(psb_out_unit,'("Standard Vector Operations")') if (iam == psb_root_) write(psb_out_unit,'(" ")') ! X = 1 - call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) - hasitnotfailed = psb_check_ans(x,one,ictxt) + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + hasitnotfailed = psb_check_ans(x,one,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> Constant vector ")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- Constant vector ")') end if ! X = 1 , Y = -2, Y = X + Y = 1 -2 = -1 - call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,negativetwo,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,negativetwo,idim,ctxt,desc_a,info) call psb_geaxpby(one,x,one,y,desc_a,info) - hasitnotfailed = psb_check_ans(y,negativeone,ictxt) + hasitnotfailed = psb_check_ans(y,negativeone,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = X + Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = X + Y ")') end if ! X = 1 , Y = 2, Y = -X + Y = -1 +2 = 1 - call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,two,idim,ctxt,desc_a,info) call psb_geaxpby(negativeone,x,one,y,desc_a,info) - hasitnotfailed = psb_check_ans(y,one,ictxt) + hasitnotfailed = psb_check_ans(y,one,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = -X + Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = -X + Y ")') end if ! X = 2 , Y = -2, Y = 0.5*X + Y = 1 - 2 = -1 - call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,negativetwo,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,negativetwo,idim,ctxt,desc_a,info) call psb_geaxpby(onehalf,x,one,y,desc_a,info) - hasitnotfailed = psb_check_ans(y,negativeone,ictxt) + hasitnotfailed = psb_check_ans(y,negativeone,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = 0.5 X + Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = 0.5 X + Y ")') end if ! X = -2 , Y = 1, Z = 0, Z = X + Y = -2 + 1 = -1 - call psb_d_gen_const(x,negativetwo,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,one,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,negativetwo,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_geaxpby(one,x,one,y,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = X + Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = X + Y ")') end if ! X = 2 , Y = 1, Z = 0, Z = X - Y = 2 - 1 = 1 - call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,one,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_geaxpby(one,x,negativeone,y,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,one,ictxt) + hasitnotfailed = psb_check_ans(z,one,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = X - Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = X - Y ")') end if ! X = 2 , Y = 1, Z = 0, Z = -X + Y = -2 + 1 = -1 - call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,one,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_geaxpby(negativeone,x,one,y,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = -X + Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = -X + Y ")') end if ! X = 2 , Y = -0.5, Z = 0, Z = X*Y = 2*(-0.5) = -1 - call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,negativeonehalf,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,negativeonehalf,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_gemlt(one,x,y,dzero,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> mlt Z = X*Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- mlt Z = X*Y ")') end if ! X = 1 , Y = 2, Z = 0, Z = X/Y = 1/2 = 0.5 - call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,two,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_gediv(x,y,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,onehalf,ictxt) + hasitnotfailed = psb_check_ans(z,onehalf,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> div Z = X/Y")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- div Z = X/Y ")') end if ! X = -1 , Z = 0, Z = |X| = |-1| = 1 - call psb_d_gen_const(x,negativeone,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,negativeone,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_geabs(x,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,one,ictxt) + hasitnotfailed = psb_check_ans(z,one,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> abs Z = |X|")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- abs Z = |X| ")') end if ! X = 2 , Z = 0, Z = 1/X = 1/2 = 0.5 - call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_geinv(x,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,onehalf,ictxt) + hasitnotfailed = psb_check_ans(z,onehalf,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> inv Z = 1/X")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- inv Z = 1/X ")') end if ! X = 1, Z = 0, c = -2, Z = X + c = -1 - call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) - call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,one,idim,ctxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ctxt,desc_a,info) call psb_geaddconst(x,negativetwo,z,desc_a,info) - hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + hasitnotfailed = psb_check_ans(z,negativeone,ctxt) if (iam == psb_root_) then if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> Add constant Z = X + c")') if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- Add constant Z = X + c")') @@ -346,15 +348,15 @@ program vecoperation if (iam == psb_root_) write(psb_out_unit,'(" ")') ! Dot product - call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) - call psb_d_gen_const(y,onehalf,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,two,idim,ctxt,desc_a,info) + call psb_d_gen_const(y,onehalf,idim,ctxt,desc_a,info) ans = psb_gedot(x,y,desc_a,info) if (iam == psb_root_) then if(ans == np*idim) write(psb_out_unit,'("TEST PASSED >>> Dot product")') if(ans /= np*idim) write(psb_out_unit,'("TEST FAILED --- Dot product")') end if ! MaxNorm - call psb_d_gen_const(x,negativeonehalf,idim,ictxt,desc_a,info) + call psb_d_gen_const(x,negativeonehalf,idim,ctxt,desc_a,info) ans = psb_geamax(x,desc_a,info) if (iam == psb_root_) then if(ans == onehalf) write(psb_out_unit,'("TEST PASSED >>> MaxNorm")') @@ -374,10 +376,10 @@ program vecoperation - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop end program vecoperation diff --git a/test/pargen/psb_d_pde2d.f90 b/test/pargen/psb_d_pde2d.f90 index 4b8b6584..1ccd7f32 100644 --- a/test/pargen/psb_d_pde2d.f90 +++ b/test/pargen/psb_d_pde2d.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,23 +27,23 @@ ! 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. -! -! +! +! ! File: psb_d_pde2d.f90 ! ! Program: psb_d_pde2d ! This sample program solves a linear system obtained by discretizing a -! PDE with Dirichlet BCs. -! +! PDE with Dirichlet BCs. +! ! ! The PDE is a general second order equation in 2d ! -! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) +! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) ! - ------ - ------ ----- + ------ + c u = f -! dxdx dydy dx dy +! dxdx dydy dx dy ! ! with Dirichlet boundary conditions -! u = g +! u = g ! ! on the unit square 0<=x,y<=1. ! @@ -63,31 +63,31 @@ module psb_d_pde2d_mod & psb_dspmat_type, psb_d_vect_type, dzero,& & psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type - interface + interface function d_func_2d(x,y) result(val) import :: psb_dpk_ real(psb_dpk_), intent(in) :: x,y real(psb_dpk_) :: val end function d_func_2d - end interface + end interface interface psb_gen_pde2d module procedure psb_d_gen_pde2d end interface psb_gen_pde2d - + contains - + function d_null_func_2d(x,y) result(val) real(psb_dpk_), intent(in) :: x,y real(psb_dpk_) :: val - + val = dzero end function d_null_func_2d ! - ! functions parametrizing the differential equation + ! functions parametrizing the differential equation ! ! @@ -101,48 +101,48 @@ contains ! function b1(x,y) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: b1 real(psb_dpk_), intent(in) :: x,y b1=dzero end function b1 function b2(x,y) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: b2 real(psb_dpk_), intent(in) :: x,y b2=dzero end function b2 function c(x,y) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: c real(psb_dpk_), intent(in) :: x,y c=0.d0 end function c function a1(x,y) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none - real(psb_dpk_) :: a1 + implicit none + real(psb_dpk_) :: a1 real(psb_dpk_), intent(in) :: x,y a1=done/80 end function a1 function a2(x,y) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: a2 real(psb_dpk_), intent(in) :: x,y a2=done/80 end function a2 function g(x,y) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: g real(psb_dpk_), intent(in) :: x,y g = dzero if (x == done) then g = done - else if (x == dzero) then + else if (x == dzero) then g = exp(-y**2) end if end function g @@ -150,21 +150,21 @@ contains ! ! subroutine to allocate and fill in the coefficient matrix and - ! the rhs. + ! the rhs. ! - subroutine psb_d_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,info,& + subroutine psb_d_gen_pde2d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod ! ! Discretizes the partial differential equation - ! - ! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) + ! + ! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) ! - ------ - ------ + ----- + ------ + c u = f - ! dxdx dydy dx dy + ! dxdx dydy dx dy ! ! with Dirichlet boundary conditions - ! u = g + ! u = g ! ! on the unit square 0<=x,y<=1. ! @@ -176,7 +176,8 @@ contains type(psb_dspmat_type) :: a type(psb_d_vect_type) :: xv,bv type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info character(len=*) :: afmt procedure(d_func_2d), optional :: f class(psb_d_base_sparse_mat), optional :: amold @@ -218,10 +219,10 @@ contains name = 'create_matrix' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) - if (present(f)) then + if (present(f)) then f_ => f else f_ => d_null_func_2d @@ -241,9 +242,9 @@ contains else partition_ = 3 end if - + ! initialize array descriptor and sparse matrix storage. provide an - ! estimate of the number of non zeroes + ! estimate of the number of non zeroes m = (1_psb_lpk_)*idim*idim n = m @@ -252,8 +253,8 @@ contains t0 = psb_wtime() select case(partition_) case(1) - ! A BLOCK partition - if (present(nrl)) then + ! A BLOCK partition + if (present(nrl)) then nr = nrl else ! @@ -264,47 +265,47 @@ contains end if nt = nr - call psb_sum(ictxt,nt) - if (nt /= m) then + call psb_sum(ctxt,nt) + if (nt /= m) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! First example of use of CDALL: specify for each process a number of ! contiguous rows - ! - call psb_cdall(ictxt,desc_a,info,nl=nr) + ! + call psb_cdall(ctxt,desc_a,info,nl=nr) myidx = desc_a%get_global_indices() nlr = size(myidx) case(2) ! A partition defined by the user through IV - - if (present(iv)) then + + if (present(iv)) then if (size(iv) /= m) then write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if else write(psb_err_unit,*) iam, 'Initialization error: IV not present' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! Second example of use of CDALL: specify for each row the - ! process that owns it - ! - call psb_cdall(ictxt,desc_a,info,vg=iv) + ! process that owns it + ! + call psb_cdall(ctxt,desc_a,info,vg=iv) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -318,7 +319,7 @@ contains npy = npdims(2) allocate(bndx(0:npx),bndy(0:npy)) - ! We can reuse idx2ijk for process indices as well. + ! We can reuse idx2ijk for process indices as well. call idx2ijk(iamx,iamy,iam,npx,npy,base=0) ! Now let's split the 2D square in rectangles call dist1Didx(bndx,idim,npx) @@ -326,7 +327,7 @@ contains call dist1Didx(bndy,idim,npy) myny = bndy(iamy+1)-bndy(iamy) - ! How many indices do I own? + ! How many indices do I own? nlr = mynx*myny allocate(myidx(nlr)) ! Now, let's generate the list of indices I own @@ -341,31 +342,30 @@ contains write(psb_err_unit,*) iam,iamx,iamy, 'Initialization error: NR vs NLR ',& & nr,nlr,mynx,myny info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) end if ! ! Third example of use of CDALL: specify for each process ! the set of global indices it owns. - ! - call psb_cdall(ictxt,desc_a,info,vl=myidx) - + ! + call psb_cdall(ctxt,desc_a,info,vl=myidx) case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end select - + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) - ! define rhs from boundary conditions; also build initial guess + ! define rhs from boundary conditions; also build initial guess if (info == psb_success_) call psb_geall(xv,desc_a,info) if (info == psb_success_) call psb_geall(bv,desc_a,info) - call psb_barrier(ictxt) + call psb_barrier(ctxt) talc = psb_wtime()-t0 if (info /= psb_success_) then @@ -376,12 +376,12 @@ contains end if ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),stat=info) - if (info /= psb_success_ ) then + if (info /= psb_success_ ) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -391,14 +391,14 @@ contains ! loop over rows belonging to current process in a block ! distribution. - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do ii=1, nlr,nb - ib = min(nb,nlr-ii+1) + ib = min(nb,nlr-ii+1) icoeff = 1 do k=1,ib i=ii+k-1 - ! local matrix pointer + ! local matrix pointer glob_row=myidx(i) ! compute gridpoint coordinates call idx2ijk(ix,iy,glob_row,idim,idim) @@ -408,11 +408,11 @@ contains zt(k) = f_(x,y) ! internal point: build discretization - ! + ! ! term depending on (x-1,y) ! val(icoeff) = -a1(x,y)/sqdeltah-b1(x,y)/deltah2 - if (ix == 1) then + if (ix == 1) then zt(k) = g(dzero,y)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix-1,iy,idim,idim) @@ -421,7 +421,7 @@ contains endif ! term depending on (x,y-1) val(icoeff) = -a2(x,y)/sqdeltah-b2(x,y)/deltah2 - if (iy == 1) then + if (iy == 1) then zt(k) = g(x,dzero)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix,iy-1,idim,idim) @@ -433,10 +433,10 @@ contains val(icoeff)=(2*done)*(a1(x,y) + a2(x,y))/sqdeltah + c(x,y) call ijk2idx(icol(icoeff),ix,iy,idim,idim) irow(icoeff) = glob_row - icoeff = icoeff+1 + icoeff = icoeff+1 ! term depending on (x,y+1) val(icoeff)=-a2(x,y)/sqdeltah+b2(x,y)/deltah2 - if (iy == idim) then + if (iy == idim) then zt(k) = g(x,done)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix,iy+1,idim,idim) @@ -445,7 +445,7 @@ contains endif ! term depending on (x+1,y) val(icoeff)=-a1(x,y)/sqdeltah+b1(x,y)/deltah2 - if (ix==idim) then + if (ix==idim) then zt(k) = g(done,y)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix+1,iy,idim,idim) @@ -473,20 +473,20 @@ contains deallocate(val,irow,icol) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) else call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.' @@ -502,13 +502,13 @@ contains goto 9999 end if tasb = psb_wtime()-t1 - call psb_barrier(ictxt) - ttot = psb_wtime() - t0 + call psb_barrier(ctxt) + ttot = psb_wtime() - t0 - call psb_amx(ictxt,talc) - call psb_amx(ictxt,tgen) - call psb_amx(ictxt,tasb) - call psb_amx(ictxt,ttot) + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) if(iam == psb_root_) then tmpfmt = a%get_fmt() write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& @@ -523,7 +523,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_d_gen_pde2d @@ -544,9 +544,9 @@ program psb_d_pde2d integer(psb_ipk_) :: idim integer(psb_epk_) :: system_size - ! miscellaneous + ! miscellaneous real(psb_dpk_), parameter :: one = done - real(psb_dpk_) :: t1, t2, tprec + real(psb_dpk_) :: t1, t2, tprec ! sparse matrix and preconditioner type(psb_dspmat_type) :: a @@ -556,13 +556,22 @@ program psb_d_pde2d ! dense vectors type(psb_d_vect_type) :: xxv,bv ! parallel environment - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_dpk_) :: err, eps + ! Parameters for solvers in Block-Jacobi preconditioner + type ainvparms + character(len=12) :: alg, orth_alg, ilu_alg, ilut_scale + integer(psb_ipk_) :: fill, inv_fill + real(psb_dpk_) :: thresh, inv_thresh + end type ainvparms + type(ainvparms) :: parms + ! other variables integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -571,12 +580,12 @@ program psb_d_pde2d info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) - if (iam < 0) then + if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif if(psb_errstatus_fatal()) goto 9999 @@ -585,22 +594,22 @@ program psb_d_pde2d ! ! Hello world ! - if (iam == psb_root_) then + if (iam == psb_root_) then write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ write(*,*) 'This is the ',trim(name),' sample program' end if ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) + call get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) ! - ! allocate and fill in the coefficient matrix, rhs and initial guess + ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - call psb_gen_pde2d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) - call psb_barrier(ictxt) + call psb_gen_pde2d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -612,11 +621,45 @@ program psb_d_pde2d if (iam == psb_root_) write(psb_out_unit,'(" ")') ! ! prepare the preconditioner. - ! + ! if(iam == psb_root_) write(psb_out_unit,'("Setting preconditioner to : ",a)')ptype - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) + ! + ! Set the options for the BJAC preconditioner + ! + if (psb_toupper(ptype) == "BJAC") then + call prec%set('sub_solve', parms%alg, info) + select case (psb_toupper(parms%alg)) + case ("ILU") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('ilu_alg', parms%ilu_alg, info) + case ("ILUT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("AINV") + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + call prec%set('ainv_alg', parms%orth_alg, info) + case ("INVK") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("INVT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case default + ! Do nothing, use default setting in the init routine + end select + else + ! nothing to set for NONE or DIAG preconditioner + end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call prec%build(a,desc_a,info) if(info /= psb_success_) then @@ -628,20 +671,20 @@ program psb_d_pde2d tprec = psb_wtime()-t1 - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if (iam == psb_root_) write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec if (iam == psb_root_) write(psb_out_unit,'(" ")') call prec%descr() ! - ! iterative method parameters + ! iterative method parameters ! if(iam == psb_root_) write(psb_out_unit,'("Calling iterative method ",a)')kmethd - call psb_barrier(ictxt) - t1 = psb_wtime() + call psb_barrier(ctxt) + t1 = psb_wtime() eps = 1.d-6 - call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& - & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -650,16 +693,16 @@ program psb_d_pde2d goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() system_size = desc_a%get_global_rows() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -671,14 +714,14 @@ program psb_d_pde2d write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)')err write(psb_out_unit,'("Info on exit : ",i12)')info write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize - write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize + write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize write(psb_out_unit,'("Storage format for A: ",a)') a%get_fmt() write(psb_out_unit,'("Storage format for DESC_A: ",a)') desc_a%get_fmt() end if - ! + ! ! cleanup storage and exit ! call psb_gefree(bv,desc_a,info) @@ -693,10 +736,10 @@ program psb_d_pde2d goto 9999 end if - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop @@ -704,15 +747,16 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - integer(psb_ipk_) :: ictxt + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) + type(psb_ctxt_type) :: ctxt character(len=*) :: kmethd, ptype, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename + type(ainvparms) :: parms - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == 0) then if (command_argument_count()>0) then @@ -721,7 +765,7 @@ contains open(inp_unit,file=filename,action='read',iostat=info) if (info /= 0) then write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ictxt) + call psb_abort(ctxt) stop else write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' @@ -739,12 +783,12 @@ contains if (ip >= 4) then read(inp_unit,*) ipart else - ipart = 3 + ipart = 3 endif if (ip >= 5) then read(inp_unit,*) istopc else - istopc=1 + istopc=1 endif if (ip >= 6) then read(inp_unit,*) itmax @@ -761,8 +805,27 @@ contains else irst=1 endif + if (ip >= 9) then + read(inp_unit,*) parms%alg + read(inp_unit,*) parms%ilu_alg + read(inp_unit,*) parms%ilut_scale + read(inp_unit,*) parms%fill + read(inp_unit,*) parms%inv_fill + read(inp_unit,*) parms%thresh + read(inp_unit,*) parms%inv_thresh + read(inp_unit,*) parms%orth_alg + else + parms%alg = 'ILU' ! Block Solver ILU,ILUT,INVK,AINVT,AORTH + parms%ilu_alg = 'NONE' ! If ILU : MILU or NONE othewise ignored + parms%ilut_scale = 'NONE' ! If ILUT: NONE, MAXVAL, DIAG, ARWSUM, ACLSUM, ARCSUM + parms%fill = 0 ! Level of fill for forward factorization + parms%inv_fill = 1 ! Level of fill for inverse factorization (only INVK) + parms%thresh = 1E-1_psb_dpk_ ! Threshold for forward factorization + parms%inv_thresh = 1E-1_psb_dpk_ ! Threshold for inverse factorization + parms%orth_alg = 'LLK' ! What orthogonalization algorithm? + endif - write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,'("Grid dimensions : ",i5," x ",i5)')idim,idim write(psb_out_unit,'("Number of processors : ",i0)') np select case(ipart) @@ -775,12 +838,41 @@ contains write(psb_out_unit,'("Unknown data distrbution, defaulting to 2D")') end select write(psb_out_unit,'("Preconditioner : ",a)') ptype + if( psb_toupper(ptype) == "BJAC" ) then + write(psb_out_unit,'("Block subsolver : ",a)') parms%alg + select case (psb_toupper(parms%alg)) + case ('ILU') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("MILU : ",a)') parms%ilu_alg + case ('ILUT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVK') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('AINV','AORTH') + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Orthogonalization : ",a)') parms%orth_alg + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case default + write(psb_out_unit,'("Unknown diagonal solver")') + end select + end if write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') else ! wrong number of parameter, print an error message and exit - call pr_usage(izero) - call psb_abort(ictxt) + call pr_usage(izero) + call psb_abort(ctxt) stop 1 endif if (inp_unit /= psb_inp_unit) then @@ -789,29 +881,36 @@ contains end if ! broadcast parameters to all processors - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,idim) - call psb_bcast(ictxt,ipart) - call psb_bcast(ictxt,istopc) - call psb_bcast(ictxt,itmax) - call psb_bcast(ictxt,itrace) - call psb_bcast(ictxt,irst) - + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,idim) + call psb_bcast(ctxt,ipart) + call psb_bcast(ctxt,istopc) + call psb_bcast(ctxt,itmax) + call psb_bcast(ctxt,itrace) + call psb_bcast(ctxt,irst) + call psb_bcast(ctxt,parms%alg) + call psb_bcast(ctxt,parms%fill) + call psb_bcast(ctxt,parms%inv_fill) + call psb_bcast(ctxt,parms%thresh) + call psb_bcast(ctxt,parms%inv_thresh) + call psb_bcast(ctxt,parms%orth_alg) + call psb_bcast(ctxt,parms%ilut_scale) + return end subroutine get_parms ! - ! print an error message - ! + ! print an error message + ! subroutine pr_usage(iout) integer(psb_ipk_) :: iout write(iout,*)'incorrect parameter(s) found' write(iout,*)' usage: pde2d90 methd prec dim & - &[ipart istop itmax itrace]' + &[ipart istop itmax itrace]' write(iout,*)' where:' - write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' write(iout,*)' prec : bjac diag none' write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' @@ -819,11 +918,9 @@ contains write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' - write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' itrace <=0 (no tracing, default) or ' write(iout,*)' >= 1 do tracing every itrace' - write(iout,*)' iterations ' + write(iout,*)' iterations ' end subroutine pr_usage end program psb_d_pde2d - - diff --git a/test/pargen/psb_d_pde3d.f90 b/test/pargen/psb_d_pde3d.f90 index 429e9a0e..4630d946 100644 --- a/test/pargen/psb_d_pde3d.f90 +++ b/test/pargen/psb_d_pde3d.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,23 +27,23 @@ ! 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. -! -! +! +! ! File: psb_d_pde3d.f90 ! ! Program: psb_d_pde3d ! This sample program solves a linear system obtained by discretizing a -! PDE with Dirichlet BCs. -! +! PDE with Dirichlet BCs. +! ! ! The PDE is a general second order equation in 3d ! -! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) +! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) ! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f -! dxdx dydy dzdz dx dy dz +! dxdx dydy dzdz dx dy dz ! ! with Dirichlet boundary conditions -! u = g +! u = g ! ! on the unit cube 0<=x,y,z<=1. ! @@ -60,37 +60,37 @@ ! module psb_d_pde3d_mod - + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_lpk_, psb_desc_type,& & psb_dspmat_type, psb_d_vect_type, dzero,& & psb_d_base_sparse_mat, psb_d_base_vect_type, & & psb_i_base_vect_type, psb_l_base_vect_type - interface + interface function d_func_3d(x,y,z) result(val) import :: psb_dpk_ real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_) :: val end function d_func_3d - end interface + end interface interface psb_gen_pde3d module procedure psb_d_gen_pde3d end interface psb_gen_pde3d - + contains function d_null_func_3d(x,y,z) result(val) real(psb_dpk_), intent(in) :: x,y,z real(psb_dpk_) :: val - + val = dzero end function d_null_func_3d ! - ! functions parametrizing the differential equation - ! + ! functions parametrizing the differential equation + ! ! ! Note: b1, b2 and b3 are the coefficients of the first @@ -103,84 +103,84 @@ contains ! function b1(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: b1 real(psb_dpk_), intent(in) :: x,y,z b1=dzero end function b1 function b2(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: b2 real(psb_dpk_), intent(in) :: x,y,z b2=dzero end function b2 function b3(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: b3 - real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_), intent(in) :: x,y,z b3=dzero end function b3 function c(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: c - real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_), intent(in) :: x,y,z c=dzero end function c function a1(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none - real(psb_dpk_) :: a1 + implicit none + real(psb_dpk_) :: a1 real(psb_dpk_), intent(in) :: x,y,z a1=done/80 end function a1 function a2(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: a2 real(psb_dpk_), intent(in) :: x,y,z a2=done/80 end function a2 function a3(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: a3 real(psb_dpk_), intent(in) :: x,y,z a3=done/80 end function a3 function g(x,y,z) use psb_base_mod, only : psb_dpk_, done, dzero - implicit none + implicit none real(psb_dpk_) :: g real(psb_dpk_), intent(in) :: x,y,z g = dzero if (x == done) then g = done - else if (x == dzero) then + else if (x == dzero) then g = exp(y**2-z**2) end if end function g - + ! ! subroutine to allocate and fill in the coefficient matrix and - ! the rhs. + ! the rhs. ! - subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,info,& + subroutine psb_d_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod ! ! Discretizes the partial differential equation - ! - ! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) + ! + ! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) ! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f - ! dxdx dydy dzdz dx dy dz + ! dxdx dydy dzdz dx dy dz ! ! with Dirichlet boundary conditions - ! u = g + ! u = g ! ! on the unit cube 0<=x,y,z<=1. ! @@ -192,11 +192,12 @@ contains type(psb_dspmat_type) :: a type(psb_d_vect_type) :: xv,bv type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info character(len=*) :: afmt procedure(d_func_3d), optional :: f class(psb_d_base_sparse_mat), optional :: amold - class(psb_d_base_vect_type), optional :: vmold + class(psb_d_base_vect_type), optional :: vmold class(psb_i_base_vect_type), optional :: imold integer(psb_ipk_), optional :: partition, nrl,iv(:) @@ -234,10 +235,10 @@ contains name = 'create_matrix' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) - if (present(f)) then + if (present(f)) then f_ => f else f_ => d_null_func_3d @@ -257,10 +258,10 @@ contains else partition_ = 3 end if - + ! initialize array descriptor and sparse matrix storage. provide an - ! estimate of the number of non zeroes - + ! estimate of the number of non zeroes + m = (1_psb_lpk_*idim)*idim*idim n = m nnz = ((n*7)/(np)) @@ -268,8 +269,8 @@ contains t0 = psb_wtime() select case(partition_) case(1) - ! A BLOCK partition - if (present(nrl)) then + ! A BLOCK partition + if (present(nrl)) then nr = nrl else ! @@ -280,47 +281,47 @@ contains end if nt = nr - call psb_sum(ictxt,nt) - if (nt /= m) then + call psb_sum(ctxt,nt) + if (nt /= m) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! First example of use of CDALL: specify for each process a number of ! contiguous rows - ! - call psb_cdall(ictxt,desc_a,info,nl=nr) + ! + call psb_cdall(ctxt,desc_a,info,nl=nr) myidx = desc_a%get_global_indices() nlr = size(myidx) case(2) ! A partition defined by the user through IV - - if (present(iv)) then + + if (present(iv)) then if (size(iv) /= m) then write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if else write(psb_err_unit,*) iam, 'Initialization error: IV not present' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! Second example of use of CDALL: specify for each row the - ! process that owns it - ! - call psb_cdall(ictxt,desc_a,info,vg=iv) + ! process that owns it + ! + call psb_cdall(ctxt,desc_a,info,vg=iv) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -335,7 +336,7 @@ contains npz = npdims(3) allocate(bndx(0:npx),bndy(0:npy),bndz(0:npz)) - ! We can reuse idx2ijk for process indices as well. + ! We can reuse idx2ijk for process indices as well. call idx2ijk(iamx,iamy,iamz,iam,npx,npy,npz,base=0) ! Now let's split the 3D cube in hexahedra call dist1Didx(bndx,idim,npx) @@ -345,7 +346,7 @@ contains call dist1Didx(bndz,idim,npz) mynz = bndz(iamz+1)-bndz(iamz) - ! How many indices do I own? + ! How many indices do I own? nlr = mynx*myny*mynz allocate(myidx(nlr)) ! Now, let's generate the list of indices I own @@ -362,31 +363,30 @@ contains write(psb_err_unit,*) iam,iamx,iamy,iamz, 'Initialization error: NR vs NLR ',& & nr,nlr,mynx,myny,mynz info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) end if ! ! Third example of use of CDALL: specify for each process ! the set of global indices it owns. - ! - call psb_cdall(ictxt,desc_a,info,vl=myidx) - + ! + call psb_cdall(ctxt,desc_a,info,vl=myidx) case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end select - + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) - ! define rhs from boundary conditions; also build initial guess + ! define rhs from boundary conditions; also build initial guess if (info == psb_success_) call psb_geall(xv,desc_a,info) if (info == psb_success_) call psb_geall(bv,desc_a,info) - call psb_barrier(ictxt) + call psb_barrier(ctxt) talc = psb_wtime()-t0 if (info /= psb_success_) then @@ -397,12 +397,12 @@ contains end if ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),stat=info) - if (info /= psb_success_ ) then + if (info /= psb_success_ ) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -412,14 +412,14 @@ contains ! loop over rows belonging to current process in a block ! distribution. - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do ii=1, nlr,nb - ib = min(nb,nlr-ii+1) + ib = min(nb,nlr-ii+1) icoeff = 1 do k=1,ib i=ii+k-1 - ! local matrix pointer + ! local matrix pointer glob_row=myidx(i) ! compute gridpoint coordinates call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) @@ -429,11 +429,11 @@ contains z = (iz-1)*deltah zt(k) = f_(x,y,z) ! internal point: build discretization - ! + ! ! term depending on (x-1,y,z) ! val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 - if (ix == 1) then + if (ix == 1) then zt(k) = g(dzero,y,z)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) @@ -442,19 +442,19 @@ contains endif ! term depending on (x,y-1,z) val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 - if (iy == 1) then + if (iy == 1) then zt(k) = g(x,dzero,z)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif ! term depending on (x,y,z-1) val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 - if (iz == 1) then + if (iz == 1) then zt(k) = g(x,y,dzero)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif @@ -462,33 +462,33 @@ contains ! term depending on (x,y,z) val(icoeff)=(2*done)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & & + c(x,y,z) - call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) irow(icoeff) = glob_row - icoeff = icoeff+1 + icoeff = icoeff+1 ! term depending on (x,y,z+1) val(icoeff)=-a3(x,y,z)/sqdeltah+b3(x,y,z)/deltah2 - if (iz == idim) then + if (iz == idim) then zt(k) = g(x,y,done)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif ! term depending on (x,y+1,z) val(icoeff)=-a2(x,y,z)/sqdeltah+b2(x,y,z)/deltah2 - if (iy == idim) then + if (iy == idim) then zt(k) = g(x,done,z)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif ! term depending on (x+1,y,z) val(icoeff)=-a1(x,y,z)/sqdeltah+b1(x,y,z)/deltah2 - if (ix==idim) then + if (ix==idim) then zt(k) = g(done,y,z)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif @@ -513,20 +513,20 @@ contains deallocate(val,irow,icol) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) else call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.' @@ -542,13 +542,13 @@ contains goto 9999 end if tasb = psb_wtime()-t1 - call psb_barrier(ictxt) - ttot = psb_wtime() - t0 + call psb_barrier(ctxt) + ttot = psb_wtime() - t0 - call psb_amx(ictxt,talc) - call psb_amx(ictxt,tgen) - call psb_amx(ictxt,tasb) - call psb_amx(ictxt,ttot) + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) if(iam == psb_root_) then tmpfmt = a%get_fmt() write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& @@ -563,7 +563,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_d_gen_pde3d @@ -585,9 +585,9 @@ program psb_d_pde3d integer(psb_ipk_) :: idim integer(psb_epk_) :: system_size - ! miscellaneous + ! miscellaneous real(psb_dpk_), parameter :: one = done - real(psb_dpk_) :: t1, t2, tprec + real(psb_dpk_) :: t1, t2, tprec ! sparse matrix and preconditioner type(psb_dspmat_type) :: a @@ -597,13 +597,22 @@ program psb_d_pde3d ! dense vectors type(psb_d_vect_type) :: xxv,bv ! parallel environment - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_dpk_) :: err, eps + ! Parameters for solvers in Block-Jacobi preconditioner + type ainvparms + character(len=12) :: alg, orth_alg, ilu_alg, ilut_scale + integer(psb_ipk_) :: fill, inv_fill + real(psb_dpk_) :: thresh, inv_thresh + end type ainvparms + type(ainvparms) :: parms + ! other variables integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -612,12 +621,12 @@ program psb_d_pde3d info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) - if (iam < 0) then + if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif if(psb_errstatus_fatal()) goto 9999 @@ -626,22 +635,21 @@ program psb_d_pde3d ! ! Hello world ! - if (iam == psb_root_) then + if (iam == psb_root_) then write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ write(*,*) 'This is the ',trim(name),' sample program' end if ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - + call get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) ! - ! allocate and fill in the coefficient matrix, rhs and initial guess + ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) - call psb_barrier(ictxt) + call psb_gen_pde3d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -653,11 +661,45 @@ program psb_d_pde3d if (iam == psb_root_) write(psb_out_unit,'(" ")') ! ! prepare the preconditioner. - ! + ! if(iam == psb_root_) write(psb_out_unit,'("Setting preconditioner to : ",a)')ptype - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) + ! + ! Set the options for the BJAC preconditioner + ! + if (psb_toupper(ptype) == "BJAC") then + call prec%set('sub_solve', parms%alg, info) + select case (psb_toupper(parms%alg)) + case ("ILU") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('ilu_alg', parms%ilu_alg, info) + case ("ILUT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("AINV") + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + call prec%set('ainv_alg', parms%orth_alg, info) + case ("INVK") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("INVT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case default + ! Do nothing, use default setting in the init routine + end select + else + ! nothing to set for NONE or DIAG preconditioner + end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call prec%build(a,desc_a,info) if(info /= psb_success_) then @@ -669,20 +711,20 @@ program psb_d_pde3d tprec = psb_wtime()-t1 - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if (iam == psb_root_) write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec if (iam == psb_root_) write(psb_out_unit,'(" ")') call prec%descr() ! - ! iterative method parameters + ! iterative method parameters ! if(iam == psb_root_) write(psb_out_unit,'("Calling iterative method ",a)')kmethd - call psb_barrier(ictxt) - t1 = psb_wtime() + call psb_barrier(ctxt) + t1 = psb_wtime() eps = 1.d-6 - call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& - & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -691,16 +733,16 @@ program psb_d_pde3d goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() system_size = desc_a%get_global_rows() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -712,14 +754,14 @@ program psb_d_pde3d write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)')err write(psb_out_unit,'("Info on exit : ",i12)')info write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize - write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize + write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize write(psb_out_unit,'("Storage format for A: ",a)') a%get_fmt() write(psb_out_unit,'("Storage format for DESC_A: ",a)') desc_a%get_fmt() end if - ! + ! ! cleanup storage and exit ! call psb_gefree(bv,desc_a,info) @@ -734,10 +776,10 @@ program psb_d_pde3d goto 9999 end if - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop @@ -745,15 +787,17 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - integer(psb_ipk_) :: ictxt + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,& + & itmax,itrace,irst,ipart,parms) + type(psb_ctxt_type) :: ctxt character(len=*) :: kmethd, ptype, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename + type(ainvparms) :: parms - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == 0) then if (command_argument_count()>0) then @@ -762,7 +806,7 @@ contains open(inp_unit,file=filename,action='read',iostat=info) if (info /= 0) then write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ictxt) + call psb_abort(ctxt) stop else write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' @@ -780,12 +824,12 @@ contains if (ip >= 4) then read(inp_unit,*) ipart else - ipart = 3 + ipart = 3 endif if (ip >= 5) then read(inp_unit,*) istopc else - istopc=1 + istopc=1 endif if (ip >= 6) then read(inp_unit,*) itmax @@ -802,8 +846,27 @@ contains else irst=1 endif + if (ip >= 9) then + read(inp_unit,*) parms%alg + read(inp_unit,*) parms%ilu_alg + read(inp_unit,*) parms%ilut_scale + read(inp_unit,*) parms%fill + read(inp_unit,*) parms%inv_fill + read(inp_unit,*) parms%thresh + read(inp_unit,*) parms%inv_thresh + read(inp_unit,*) parms%orth_alg + else + parms%alg = 'ILU' ! Block Solver ILU,ILUT,INVK,AINVT,AORTH + parms%ilu_alg = 'NONE' ! If ILU : MILU or NONE othewise ignored + parms%ilut_scale = 'NONE' ! If ILUT: NONE, MAXVAL, DIAG, ARWSUM, ACLSUM, ARCSUM + parms%fill = 0 ! Level of fill for forward factorization + parms%inv_fill = 1 ! Level of fill for inverse factorization (only INVK) + parms%thresh = 1E-1_psb_dpk_ ! Threshold for forward factorization + parms%inv_thresh = 1E-1_psb_dpk_ ! Threshold for inverse factorization + parms%orth_alg = 'LLK' ! What orthogonalization algorithm? + endif - write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,& & '("Grid dimensions : ",i4," x ",i4," x ",i4)') & & idim,idim,idim @@ -818,12 +881,41 @@ contains write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")') end select write(psb_out_unit,'("Preconditioner : ",a)') ptype + if( psb_toupper(ptype) == "BJAC" ) then + write(psb_out_unit,'("Block subsolver : ",a)') parms%alg + select case (psb_toupper(parms%alg)) + case ('ILU') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("MILU : ",a)') parms%ilu_alg + case ('ILUT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVK') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('AINV','AORTH') + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Orthogonalization : ",a)') parms%orth_alg + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case default + write(psb_out_unit,'("Unknown diagonal solver")') + end select + end if write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') else ! wrong number of parameter, print an error message and exit - call pr_usage(izero) - call psb_abort(ictxt) + call pr_usage(izero) + call psb_abort(ctxt) stop 1 endif if (inp_unit /= psb_inp_unit) then @@ -832,29 +924,36 @@ contains end if ! broadcast parameters to all processors - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,idim) - call psb_bcast(ictxt,ipart) - call psb_bcast(ictxt,istopc) - call psb_bcast(ictxt,itmax) - call psb_bcast(ictxt,itrace) - call psb_bcast(ictxt,irst) + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,idim) + call psb_bcast(ctxt,ipart) + call psb_bcast(ctxt,istopc) + call psb_bcast(ctxt,itmax) + call psb_bcast(ctxt,itrace) + call psb_bcast(ctxt,irst) + call psb_bcast(ctxt,parms%alg) + call psb_bcast(ctxt,parms%fill) + call psb_bcast(ctxt,parms%inv_fill) + call psb_bcast(ctxt,parms%thresh) + call psb_bcast(ctxt,parms%inv_thresh) + call psb_bcast(ctxt,parms%orth_alg) + call psb_bcast(ctxt,parms%ilut_scale) return end subroutine get_parms ! - ! print an error message - ! + ! print an error message + ! subroutine pr_usage(iout) integer(psb_ipk_) :: iout write(iout,*)'incorrect parameter(s) found' write(iout,*)' usage: pde3d90 methd prec dim & - &[istop itmax itrace]' + &[istop itmax itrace]' write(iout,*)' where:' - write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' write(iout,*)' prec : bjac diag none' write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' @@ -862,11 +961,9 @@ contains write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' - write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' itrace <=0 (no tracing, default) or ' write(iout,*)' >= 1 do tracing every itrace' - write(iout,*)' iterations ' + write(iout,*)' iterations ' end subroutine pr_usage end program psb_d_pde3d - - diff --git a/test/pargen/psb_s_pde2d.f90 b/test/pargen/psb_s_pde2d.f90 index b0fe9a7e..f055e5e6 100644 --- a/test/pargen/psb_s_pde2d.f90 +++ b/test/pargen/psb_s_pde2d.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,23 +27,23 @@ ! 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. -! -! +! +! ! File: psb_s_pde2d.f90 ! ! Program: psb_s_pde2d ! This sample program solves a linear system obtained by discretizing a -! PDE with Dirichlet BCs. -! +! PDE with Dirichlet BCs. +! ! ! The PDE is a general second order equation in 2d ! -! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) +! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) ! - ------ - ------ ----- + ------ + c u = f -! dxdx dydy dx dy +! dxdx dydy dx dy ! ! with Dirichlet boundary conditions -! u = g +! u = g ! ! on the unit square 0<=x,y<=1. ! @@ -63,31 +63,31 @@ module psb_s_pde2d_mod & psb_sspmat_type, psb_s_vect_type, szero,& & psb_s_base_sparse_mat, psb_s_base_vect_type, psb_i_base_vect_type - interface + interface function s_func_2d(x,y) result(val) import :: psb_spk_ real(psb_spk_), intent(in) :: x,y real(psb_spk_) :: val end function s_func_2d - end interface + end interface interface psb_gen_pde2d module procedure psb_s_gen_pde2d end interface psb_gen_pde2d - + contains - + function s_null_func_2d(x,y) result(val) real(psb_spk_), intent(in) :: x,y real(psb_spk_) :: val - + val = szero end function s_null_func_2d ! - ! functions parametrizing the differential equation + ! functions parametrizing the differential equation ! ! @@ -101,48 +101,48 @@ contains ! function b1(x,y) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: b1 real(psb_spk_), intent(in) :: x,y b1=szero end function b1 function b2(x,y) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: b2 real(psb_spk_), intent(in) :: x,y b2=szero end function b2 function c(x,y) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: c real(psb_spk_), intent(in) :: x,y c=0.d0 end function c function a1(x,y) use psb_base_mod, only : psb_spk_, sone, szero - implicit none - real(psb_spk_) :: a1 + implicit none + real(psb_spk_) :: a1 real(psb_spk_), intent(in) :: x,y a1=sone/80 end function a1 function a2(x,y) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: a2 real(psb_spk_), intent(in) :: x,y a2=sone/80 end function a2 function g(x,y) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: g real(psb_spk_), intent(in) :: x,y g = szero if (x == sone) then g = sone - else if (x == szero) then + else if (x == szero) then g = exp(-y**2) end if end function g @@ -150,21 +150,21 @@ contains ! ! subroutine to allocate and fill in the coefficient matrix and - ! the rhs. + ! the rhs. ! - subroutine psb_s_gen_pde2d(ictxt,idim,a,bv,xv,desc_a,afmt,info,& + subroutine psb_s_gen_pde2d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod ! ! Discretizes the partial differential equation - ! - ! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) + ! + ! a1 dd(u) a2 dd(u) b1 d(u) b2 d(u) ! - ------ - ------ + ----- + ------ + c u = f - ! dxdx dydy dx dy + ! dxdx dydy dx dy ! ! with Dirichlet boundary conditions - ! u = g + ! u = g ! ! on the unit square 0<=x,y<=1. ! @@ -176,7 +176,8 @@ contains type(psb_sspmat_type) :: a type(psb_s_vect_type) :: xv,bv type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info character(len=*) :: afmt procedure(s_func_2d), optional :: f class(psb_s_base_sparse_mat), optional :: amold @@ -218,10 +219,10 @@ contains name = 'create_matrix' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) - if (present(f)) then + if (present(f)) then f_ => f else f_ => s_null_func_2d @@ -241,9 +242,9 @@ contains else partition_ = 3 end if - + ! initialize array descriptor and sparse matrix storage. provide an - ! estimate of the number of non zeroes + ! estimate of the number of non zeroes m = (1_psb_lpk_)*idim*idim n = m @@ -252,8 +253,8 @@ contains t0 = psb_wtime() select case(partition_) case(1) - ! A BLOCK partition - if (present(nrl)) then + ! A BLOCK partition + if (present(nrl)) then nr = nrl else ! @@ -264,47 +265,47 @@ contains end if nt = nr - call psb_sum(ictxt,nt) - if (nt /= m) then + call psb_sum(ctxt,nt) + if (nt /= m) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! First example of use of CDALL: specify for each process a number of ! contiguous rows - ! - call psb_cdall(ictxt,desc_a,info,nl=nr) + ! + call psb_cdall(ctxt,desc_a,info,nl=nr) myidx = desc_a%get_global_indices() nlr = size(myidx) case(2) ! A partition defined by the user through IV - - if (present(iv)) then + + if (present(iv)) then if (size(iv) /= m) then write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if else write(psb_err_unit,*) iam, 'Initialization error: IV not present' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! Second example of use of CDALL: specify for each row the - ! process that owns it - ! - call psb_cdall(ictxt,desc_a,info,vg=iv) + ! process that owns it + ! + call psb_cdall(ctxt,desc_a,info,vg=iv) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -318,7 +319,7 @@ contains npy = npdims(2) allocate(bndx(0:npx),bndy(0:npy)) - ! We can reuse idx2ijk for process indices as well. + ! We can reuse idx2ijk for process indices as well. call idx2ijk(iamx,iamy,iam,npx,npy,base=0) ! Now let's split the 2D square in rectangles call dist1Didx(bndx,idim,npx) @@ -326,7 +327,7 @@ contains call dist1Didx(bndy,idim,npy) myny = bndy(iamy+1)-bndy(iamy) - ! How many indices do I own? + ! How many indices do I own? nlr = mynx*myny allocate(myidx(nlr)) ! Now, let's generate the list of indices I own @@ -341,31 +342,30 @@ contains write(psb_err_unit,*) iam,iamx,iamy, 'Initialization error: NR vs NLR ',& & nr,nlr,mynx,myny info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) end if ! ! Third example of use of CDALL: specify for each process ! the set of global indices it owns. - ! - call psb_cdall(ictxt,desc_a,info,vl=myidx) - + ! + call psb_cdall(ctxt,desc_a,info,vl=myidx) case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end select - + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) - ! define rhs from boundary conditions; also build initial guess + ! define rhs from boundary conditions; also build initial guess if (info == psb_success_) call psb_geall(xv,desc_a,info) if (info == psb_success_) call psb_geall(bv,desc_a,info) - call psb_barrier(ictxt) + call psb_barrier(ctxt) talc = psb_wtime()-t0 if (info /= psb_success_) then @@ -376,12 +376,12 @@ contains end if ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),stat=info) - if (info /= psb_success_ ) then + if (info /= psb_success_ ) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -391,14 +391,14 @@ contains ! loop over rows belonging to current process in a block ! distribution. - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do ii=1, nlr,nb - ib = min(nb,nlr-ii+1) + ib = min(nb,nlr-ii+1) icoeff = 1 do k=1,ib i=ii+k-1 - ! local matrix pointer + ! local matrix pointer glob_row=myidx(i) ! compute gridpoint coordinates call idx2ijk(ix,iy,glob_row,idim,idim) @@ -408,11 +408,11 @@ contains zt(k) = f_(x,y) ! internal point: build discretization - ! + ! ! term depending on (x-1,y) ! val(icoeff) = -a1(x,y)/sqdeltah-b1(x,y)/deltah2 - if (ix == 1) then + if (ix == 1) then zt(k) = g(szero,y)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix-1,iy,idim,idim) @@ -421,7 +421,7 @@ contains endif ! term depending on (x,y-1) val(icoeff) = -a2(x,y)/sqdeltah-b2(x,y)/deltah2 - if (iy == 1) then + if (iy == 1) then zt(k) = g(x,szero)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix,iy-1,idim,idim) @@ -433,10 +433,10 @@ contains val(icoeff)=(2*sone)*(a1(x,y) + a2(x,y))/sqdeltah + c(x,y) call ijk2idx(icol(icoeff),ix,iy,idim,idim) irow(icoeff) = glob_row - icoeff = icoeff+1 + icoeff = icoeff+1 ! term depending on (x,y+1) val(icoeff)=-a2(x,y)/sqdeltah+b2(x,y)/deltah2 - if (iy == idim) then + if (iy == idim) then zt(k) = g(x,sone)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix,iy+1,idim,idim) @@ -445,7 +445,7 @@ contains endif ! term depending on (x+1,y) val(icoeff)=-a1(x,y)/sqdeltah+b1(x,y)/deltah2 - if (ix==idim) then + if (ix==idim) then zt(k) = g(sone,y)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix+1,iy,idim,idim) @@ -473,20 +473,20 @@ contains deallocate(val,irow,icol) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) else call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.' @@ -502,13 +502,13 @@ contains goto 9999 end if tasb = psb_wtime()-t1 - call psb_barrier(ictxt) - ttot = psb_wtime() - t0 + call psb_barrier(ctxt) + ttot = psb_wtime() - t0 - call psb_amx(ictxt,talc) - call psb_amx(ictxt,tgen) - call psb_amx(ictxt,tasb) - call psb_amx(ictxt,ttot) + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) if(iam == psb_root_) then tmpfmt = a%get_fmt() write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& @@ -523,7 +523,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_s_gen_pde2d @@ -544,9 +544,9 @@ program psb_s_pde2d integer(psb_ipk_) :: idim integer(psb_epk_) :: system_size - ! miscellaneous + ! miscellaneous real(psb_spk_), parameter :: one = sone - real(psb_dpk_) :: t1, t2, tprec + real(psb_dpk_) :: t1, t2, tprec ! sparse matrix and preconditioner type(psb_sspmat_type) :: a @@ -556,13 +556,22 @@ program psb_s_pde2d ! dense vectors type(psb_s_vect_type) :: xxv,bv ! parallel environment - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_spk_) :: err, eps + ! Parameters for solvers in Block-Jacobi preconditioner + type ainvparms + character(len=12) :: alg, orth_alg, ilu_alg, ilut_scale + integer(psb_ipk_) :: fill, inv_fill + real(psb_spk_) :: thresh, inv_thresh + end type ainvparms + type(ainvparms) :: parms + ! other variables integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -571,12 +580,12 @@ program psb_s_pde2d info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) - if (iam < 0) then + if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif if(psb_errstatus_fatal()) goto 9999 @@ -585,22 +594,22 @@ program psb_s_pde2d ! ! Hello world ! - if (iam == psb_root_) then + if (iam == psb_root_) then write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ write(*,*) 'This is the ',trim(name),' sample program' end if ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) + call get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) ! - ! allocate and fill in the coefficient matrix, rhs and initial guess + ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - call psb_gen_pde2d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) - call psb_barrier(ictxt) + call psb_gen_pde2d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -612,11 +621,45 @@ program psb_s_pde2d if (iam == psb_root_) write(psb_out_unit,'(" ")') ! ! prepare the preconditioner. - ! + ! if(iam == psb_root_) write(psb_out_unit,'("Setting preconditioner to : ",a)')ptype - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) + ! + ! Set the options for the BJAC preconditioner + ! + if (psb_toupper(ptype) == "BJAC") then + call prec%set('sub_solve', parms%alg, info) + select case (psb_toupper(parms%alg)) + case ("ILU") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('ilu_alg', parms%ilu_alg, info) + case ("ILUT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("AINV") + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + call prec%set('ainv_alg', parms%orth_alg, info) + case ("INVK") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("INVT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case default + ! Do nothing, use default setting in the init routine + end select + else + ! nothing to set for NONE or DIAG preconditioner + end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call prec%build(a,desc_a,info) if(info /= psb_success_) then @@ -628,20 +671,20 @@ program psb_s_pde2d tprec = psb_wtime()-t1 - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if (iam == psb_root_) write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec if (iam == psb_root_) write(psb_out_unit,'(" ")') call prec%descr() ! - ! iterative method parameters + ! iterative method parameters ! if(iam == psb_root_) write(psb_out_unit,'("Calling iterative method ",a)')kmethd - call psb_barrier(ictxt) - t1 = psb_wtime() + call psb_barrier(ctxt) + t1 = psb_wtime() eps = 1.d-6 - call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& - & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -650,16 +693,16 @@ program psb_s_pde2d goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() system_size = desc_a%get_global_rows() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -671,14 +714,14 @@ program psb_s_pde2d write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)')err write(psb_out_unit,'("Info on exit : ",i12)')info write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize - write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize + write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize write(psb_out_unit,'("Storage format for A: ",a)') a%get_fmt() write(psb_out_unit,'("Storage format for DESC_A: ",a)') desc_a%get_fmt() end if - ! + ! ! cleanup storage and exit ! call psb_gefree(bv,desc_a,info) @@ -693,10 +736,10 @@ program psb_s_pde2d goto 9999 end if - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop @@ -704,15 +747,16 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - integer(psb_ipk_) :: ictxt + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) + type(psb_ctxt_type) :: ctxt character(len=*) :: kmethd, ptype, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename + type(ainvparms) :: parms - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == 0) then if (command_argument_count()>0) then @@ -721,7 +765,7 @@ contains open(inp_unit,file=filename,action='read',iostat=info) if (info /= 0) then write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ictxt) + call psb_abort(ctxt) stop else write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' @@ -739,12 +783,12 @@ contains if (ip >= 4) then read(inp_unit,*) ipart else - ipart = 3 + ipart = 3 endif if (ip >= 5) then read(inp_unit,*) istopc else - istopc=1 + istopc=1 endif if (ip >= 6) then read(inp_unit,*) itmax @@ -761,8 +805,27 @@ contains else irst=1 endif + if (ip >= 9) then + read(inp_unit,*) parms%alg + read(inp_unit,*) parms%ilu_alg + read(inp_unit,*) parms%ilut_scale + read(inp_unit,*) parms%fill + read(inp_unit,*) parms%inv_fill + read(inp_unit,*) parms%thresh + read(inp_unit,*) parms%inv_thresh + read(inp_unit,*) parms%orth_alg + else + parms%alg = 'ILU' ! Block Solver ILU,ILUT,INVK,AINVT,AORTH + parms%ilu_alg = 'NONE' ! If ILU : MILU or NONE othewise ignored + parms%ilut_scale = 'NONE' ! If ILUT: NONE, MAXVAL, DIAG, ARWSUM, ACLSUM, ARCSUM + parms%fill = 0 ! Level of fill for forward factorization + parms%inv_fill = 1 ! Level of fill for inverse factorization (only INVK) + parms%thresh = 1E-1_psb_spk_ ! Threshold for forward factorization + parms%inv_thresh = 1E-1_psb_spk_ ! Threshold for inverse factorization + parms%orth_alg = 'LLK' ! What orthogonalization algorithm? + endif - write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,'("Grid dimensions : ",i5," x ",i5)')idim,idim write(psb_out_unit,'("Number of processors : ",i0)') np select case(ipart) @@ -775,12 +838,41 @@ contains write(psb_out_unit,'("Unknown data distrbution, defaulting to 2D")') end select write(psb_out_unit,'("Preconditioner : ",a)') ptype + if( psb_toupper(ptype) == "BJAC" ) then + write(psb_out_unit,'("Block subsolver : ",a)') parms%alg + select case (psb_toupper(parms%alg)) + case ('ILU') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("MILU : ",a)') parms%ilu_alg + case ('ILUT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVK') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('AINV','AORTH') + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Orthogonalization : ",a)') parms%orth_alg + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case default + write(psb_out_unit,'("Unknown diagonal solver")') + end select + end if write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') else ! wrong number of parameter, print an error message and exit - call pr_usage(izero) - call psb_abort(ictxt) + call pr_usage(izero) + call psb_abort(ctxt) stop 1 endif if (inp_unit /= psb_inp_unit) then @@ -789,29 +881,36 @@ contains end if ! broadcast parameters to all processors - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,idim) - call psb_bcast(ictxt,ipart) - call psb_bcast(ictxt,istopc) - call psb_bcast(ictxt,itmax) - call psb_bcast(ictxt,itrace) - call psb_bcast(ictxt,irst) - + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,idim) + call psb_bcast(ctxt,ipart) + call psb_bcast(ctxt,istopc) + call psb_bcast(ctxt,itmax) + call psb_bcast(ctxt,itrace) + call psb_bcast(ctxt,irst) + call psb_bcast(ctxt,parms%alg) + call psb_bcast(ctxt,parms%fill) + call psb_bcast(ctxt,parms%inv_fill) + call psb_bcast(ctxt,parms%thresh) + call psb_bcast(ctxt,parms%inv_thresh) + call psb_bcast(ctxt,parms%orth_alg) + call psb_bcast(ctxt,parms%ilut_scale) + return end subroutine get_parms ! - ! print an error message - ! + ! print an error message + ! subroutine pr_usage(iout) integer(psb_ipk_) :: iout write(iout,*)'incorrect parameter(s) found' write(iout,*)' usage: pde2d90 methd prec dim & - &[ipart istop itmax itrace]' + &[ipart istop itmax itrace]' write(iout,*)' where:' - write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' write(iout,*)' prec : bjac diag none' write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' @@ -819,11 +918,9 @@ contains write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' - write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' itrace <=0 (no tracing, default) or ' write(iout,*)' >= 1 do tracing every itrace' - write(iout,*)' iterations ' + write(iout,*)' iterations ' end subroutine pr_usage end program psb_s_pde2d - - diff --git a/test/pargen/psb_s_pde3d.f90 b/test/pargen/psb_s_pde3d.f90 index e7c7725e..0bc77248 100644 --- a/test/pargen/psb_s_pde3d.f90 +++ b/test/pargen/psb_s_pde3d.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific 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 @@ -27,23 +27,23 @@ ! 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. -! -! +! +! ! File: psb_s_pde3d.f90 ! ! Program: psb_s_pde3d ! This sample program solves a linear system obtained by discretizing a -! PDE with Dirichlet BCs. -! +! PDE with Dirichlet BCs. +! ! ! The PDE is a general second order equation in 3d ! -! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) +! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) ! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f -! dxdx dydy dzdz dx dy dz +! dxdx dydy dzdz dx dy dz ! ! with Dirichlet boundary conditions -! u = g +! u = g ! ! on the unit cube 0<=x,y,z<=1. ! @@ -60,37 +60,37 @@ ! module psb_s_pde3d_mod - + use psb_base_mod, only : psb_spk_, psb_ipk_, psb_lpk_, psb_desc_type,& & psb_sspmat_type, psb_s_vect_type, szero,& & psb_s_base_sparse_mat, psb_s_base_vect_type, & & psb_i_base_vect_type, psb_l_base_vect_type - interface + interface function s_func_3d(x,y,z) result(val) import :: psb_spk_ real(psb_spk_), intent(in) :: x,y,z real(psb_spk_) :: val end function s_func_3d - end interface + end interface interface psb_gen_pde3d module procedure psb_s_gen_pde3d end interface psb_gen_pde3d - + contains function s_null_func_3d(x,y,z) result(val) real(psb_spk_), intent(in) :: x,y,z real(psb_spk_) :: val - + val = szero end function s_null_func_3d ! - ! functions parametrizing the differential equation - ! + ! functions parametrizing the differential equation + ! ! ! Note: b1, b2 and b3 are the coefficients of the first @@ -103,84 +103,84 @@ contains ! function b1(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: b1 real(psb_spk_), intent(in) :: x,y,z b1=szero end function b1 function b2(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: b2 real(psb_spk_), intent(in) :: x,y,z b2=szero end function b2 function b3(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: b3 - real(psb_spk_), intent(in) :: x,y,z + real(psb_spk_), intent(in) :: x,y,z b3=szero end function b3 function c(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: c - real(psb_spk_), intent(in) :: x,y,z + real(psb_spk_), intent(in) :: x,y,z c=szero end function c function a1(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none - real(psb_spk_) :: a1 + implicit none + real(psb_spk_) :: a1 real(psb_spk_), intent(in) :: x,y,z a1=sone/80 end function a1 function a2(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: a2 real(psb_spk_), intent(in) :: x,y,z a2=sone/80 end function a2 function a3(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: a3 real(psb_spk_), intent(in) :: x,y,z a3=sone/80 end function a3 function g(x,y,z) use psb_base_mod, only : psb_spk_, sone, szero - implicit none + implicit none real(psb_spk_) :: g real(psb_spk_), intent(in) :: x,y,z g = szero if (x == sone) then g = sone - else if (x == szero) then + else if (x == szero) then g = exp(y**2-z**2) end if end function g - + ! ! subroutine to allocate and fill in the coefficient matrix and - ! the rhs. + ! the rhs. ! - subroutine psb_s_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,info,& + subroutine psb_s_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,info,& & f,amold,vmold,imold,partition,nrl,iv) use psb_base_mod use psb_util_mod ! ! Discretizes the partial differential equation - ! - ! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) + ! + ! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) ! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f - ! dxdx dydy dzdz dx dy dz + ! dxdx dydy dzdz dx dy dz ! ! with Dirichlet boundary conditions - ! u = g + ! u = g ! ! on the unit cube 0<=x,y,z<=1. ! @@ -192,11 +192,12 @@ contains type(psb_sspmat_type) :: a type(psb_s_vect_type) :: xv,bv type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info character(len=*) :: afmt procedure(s_func_3d), optional :: f class(psb_s_base_sparse_mat), optional :: amold - class(psb_s_base_vect_type), optional :: vmold + class(psb_s_base_vect_type), optional :: vmold class(psb_i_base_vect_type), optional :: imold integer(psb_ipk_), optional :: partition, nrl,iv(:) @@ -234,10 +235,10 @@ contains name = 'create_matrix' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) - if (present(f)) then + if (present(f)) then f_ => f else f_ => s_null_func_3d @@ -257,10 +258,10 @@ contains else partition_ = 3 end if - + ! initialize array descriptor and sparse matrix storage. provide an - ! estimate of the number of non zeroes - + ! estimate of the number of non zeroes + m = (1_psb_lpk_*idim)*idim*idim n = m nnz = ((n*7)/(np)) @@ -268,8 +269,8 @@ contains t0 = psb_wtime() select case(partition_) case(1) - ! A BLOCK partition - if (present(nrl)) then + ! A BLOCK partition + if (present(nrl)) then nr = nrl else ! @@ -280,47 +281,47 @@ contains end if nt = nr - call psb_sum(ictxt,nt) - if (nt /= m) then + call psb_sum(ctxt,nt) + if (nt /= m) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! First example of use of CDALL: specify for each process a number of ! contiguous rows - ! - call psb_cdall(ictxt,desc_a,info,nl=nr) + ! + call psb_cdall(ctxt,desc_a,info,nl=nr) myidx = desc_a%get_global_indices() nlr = size(myidx) case(2) ! A partition defined by the user through IV - - if (present(iv)) then + + if (present(iv)) then if (size(iv) /= m) then write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if else write(psb_err_unit,*) iam, 'Initialization error: IV not present' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) - return + call psb_barrier(ctxt) + call psb_abort(ctxt) + return end if ! ! Second example of use of CDALL: specify for each row the - ! process that owns it - ! - call psb_cdall(ictxt,desc_a,info,vg=iv) + ! process that owns it + ! + call psb_cdall(ctxt,desc_a,info,vg=iv) myidx = desc_a%get_global_indices() nlr = size(myidx) @@ -335,7 +336,7 @@ contains npz = npdims(3) allocate(bndx(0:npx),bndy(0:npy),bndz(0:npz)) - ! We can reuse idx2ijk for process indices as well. + ! We can reuse idx2ijk for process indices as well. call idx2ijk(iamx,iamy,iamz,iam,npx,npy,npz,base=0) ! Now let's split the 3D cube in hexahedra call dist1Didx(bndx,idim,npx) @@ -345,7 +346,7 @@ contains call dist1Didx(bndz,idim,npz) mynz = bndz(iamz+1)-bndz(iamz) - ! How many indices do I own? + ! How many indices do I own? nlr = mynx*myny*mynz allocate(myidx(nlr)) ! Now, let's generate the list of indices I own @@ -362,31 +363,30 @@ contains write(psb_err_unit,*) iam,iamx,iamy,iamz, 'Initialization error: NR vs NLR ',& & nr,nlr,mynx,myny,mynz info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) end if ! ! Third example of use of CDALL: specify for each process ! the set of global indices it owns. - ! - call psb_cdall(ictxt,desc_a,info,vl=myidx) - + ! + call psb_cdall(ctxt,desc_a,info,vl=myidx) case default write(psb_err_unit,*) iam, 'Initialization error: should not get here' info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end select - + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) - ! define rhs from boundary conditions; also build initial guess + ! define rhs from boundary conditions; also build initial guess if (info == psb_success_) call psb_geall(xv,desc_a,info) if (info == psb_success_) call psb_geall(bv,desc_a,info) - call psb_barrier(ictxt) + call psb_barrier(ctxt) talc = psb_wtime()-t0 if (info /= psb_success_) then @@ -397,12 +397,12 @@ contains end if ! we build an auxiliary matrix consisting of one row at a - ! time; just a small matrix. might be extended to generate - ! a bunch of rows per call. - ! + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),stat=info) - if (info /= psb_success_ ) then + if (info /= psb_success_ ) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -412,14 +412,14 @@ contains ! loop over rows belonging to current process in a block ! distribution. - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do ii=1, nlr,nb - ib = min(nb,nlr-ii+1) + ib = min(nb,nlr-ii+1) icoeff = 1 do k=1,ib i=ii+k-1 - ! local matrix pointer + ! local matrix pointer glob_row=myidx(i) ! compute gridpoint coordinates call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) @@ -429,11 +429,11 @@ contains z = (iz-1)*deltah zt(k) = f_(x,y,z) ! internal point: build discretization - ! + ! ! term depending on (x-1,y,z) ! val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 - if (ix == 1) then + if (ix == 1) then zt(k) = g(szero,y,z)*(-val(icoeff)) + zt(k) else call ijk2idx(icol(icoeff),ix-1,iy,iz,idim,idim,idim) @@ -442,19 +442,19 @@ contains endif ! term depending on (x,y-1,z) val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 - if (iy == 1) then + if (iy == 1) then zt(k) = g(x,szero,z)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy-1,iz,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif ! term depending on (x,y,z-1) val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 - if (iz == 1) then + if (iz == 1) then zt(k) = g(x,y,szero)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy,iz-1,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif @@ -462,33 +462,33 @@ contains ! term depending on (x,y,z) val(icoeff)=(2*sone)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & & + c(x,y,z) - call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy,iz,idim,idim,idim) irow(icoeff) = glob_row - icoeff = icoeff+1 + icoeff = icoeff+1 ! term depending on (x,y,z+1) val(icoeff)=-a3(x,y,z)/sqdeltah+b3(x,y,z)/deltah2 - if (iz == idim) then + if (iz == idim) then zt(k) = g(x,y,sone)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy,iz+1,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif ! term depending on (x,y+1,z) val(icoeff)=-a2(x,y,z)/sqdeltah+b2(x,y,z)/deltah2 - if (iy == idim) then + if (iy == idim) then zt(k) = g(x,sone,z)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix,iy+1,iz,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif ! term depending on (x+1,y,z) val(icoeff)=-a1(x,y,z)/sqdeltah+b1(x,y,z)/deltah2 - if (ix==idim) then + if (ix==idim) then zt(k) = g(sone,y,z)*(-val(icoeff)) + zt(k) else - call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) + call ijk2idx(icol(icoeff),ix+1,iy,iz,idim,idim,idim) irow(icoeff) = glob_row icoeff = icoeff+1 endif @@ -513,20 +513,20 @@ contains deallocate(val,irow,icol) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - if (info == psb_success_) then - if (present(amold)) then + if (info == psb_success_) then + if (present(amold)) then call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) else call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.' @@ -542,13 +542,13 @@ contains goto 9999 end if tasb = psb_wtime()-t1 - call psb_barrier(ictxt) - ttot = psb_wtime() - t0 + call psb_barrier(ctxt) + ttot = psb_wtime() - t0 - call psb_amx(ictxt,talc) - call psb_amx(ictxt,tgen) - call psb_amx(ictxt,tasb) - call psb_amx(ictxt,ttot) + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) if(iam == psb_root_) then tmpfmt = a%get_fmt() write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& @@ -563,7 +563,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_s_gen_pde3d @@ -585,9 +585,9 @@ program psb_s_pde3d integer(psb_ipk_) :: idim integer(psb_epk_) :: system_size - ! miscellaneous + ! miscellaneous real(psb_spk_), parameter :: one = sone - real(psb_dpk_) :: t1, t2, tprec + real(psb_dpk_) :: t1, t2, tprec ! sparse matrix and preconditioner type(psb_sspmat_type) :: a @@ -597,13 +597,22 @@ program psb_s_pde3d ! dense vectors type(psb_s_vect_type) :: xxv,bv ! parallel environment - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_spk_) :: err, eps + ! Parameters for solvers in Block-Jacobi preconditioner + type ainvparms + character(len=12) :: alg, orth_alg, ilu_alg, ilut_scale + integer(psb_ipk_) :: fill, inv_fill + real(psb_spk_) :: thresh, inv_thresh + end type ainvparms + type(ainvparms) :: parms + ! other variables integer(psb_ipk_) :: info, i character(len=20) :: name,ch_err @@ -612,12 +621,12 @@ program psb_s_pde3d info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) - if (iam < 0) then + if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif if(psb_errstatus_fatal()) goto 9999 @@ -626,22 +635,21 @@ program psb_s_pde3d ! ! Hello world ! - if (iam == psb_root_) then + if (iam == psb_root_) then write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ write(*,*) 'This is the ',trim(name),' sample program' end if ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - + call get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms) ! - ! allocate and fill in the coefficient matrix, rhs and initial guess + ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() - call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) - call psb_barrier(ictxt) + call psb_gen_pde3d(ctxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -653,11 +661,45 @@ program psb_s_pde3d if (iam == psb_root_) write(psb_out_unit,'(" ")') ! ! prepare the preconditioner. - ! + ! if(iam == psb_root_) write(psb_out_unit,'("Setting preconditioner to : ",a)')ptype - call prec%init(ictxt,ptype,info) + call prec%init(ctxt,ptype,info) + ! + ! Set the options for the BJAC preconditioner + ! + if (psb_toupper(ptype) == "BJAC") then + call prec%set('sub_solve', parms%alg, info) + select case (psb_toupper(parms%alg)) + case ("ILU") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('ilu_alg', parms%ilu_alg, info) + case ("ILUT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("AINV") + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + call prec%set('ainv_alg', parms%orth_alg, info) + case ("INVK") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case ("INVT") + call prec%set('sub_fillin', parms%fill, info) + call prec%set('inv_fillin', parms%inv_fill, info) + call prec%set('sub_iluthrs', parms%thresh, info) + call prec%set('inv_thresh', parms%inv_thresh, info) + call prec%set('ilut_scale', parms%ilut_scale, info) + case default + ! Do nothing, use default setting in the init routine + end select + else + ! nothing to set for NONE or DIAG preconditioner + end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call prec%build(a,desc_a,info) if(info /= psb_success_) then @@ -669,20 +711,20 @@ program psb_s_pde3d tprec = psb_wtime()-t1 - call psb_amx(ictxt,tprec) + call psb_amx(ctxt,tprec) if (iam == psb_root_) write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec if (iam == psb_root_) write(psb_out_unit,'(" ")') call prec%descr() ! - ! iterative method parameters + ! iterative method parameters ! if(iam == psb_root_) write(psb_out_unit,'("Calling iterative method ",a)')kmethd - call psb_barrier(ictxt) - t1 = psb_wtime() + call psb_barrier(ctxt) + t1 = psb_wtime() eps = 1.d-6 - call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& - & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -691,16 +733,16 @@ program psb_s_pde3d goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_amx(ictxt,t2) + call psb_amx(ctxt,t2) amatsize = a%sizeof() descsize = desc_a%sizeof() precsize = prec%sizeof() system_size = desc_a%get_global_rows() - call psb_sum(ictxt,amatsize) - call psb_sum(ictxt,descsize) - call psb_sum(ictxt,precsize) + call psb_sum(ctxt,amatsize) + call psb_sum(ctxt,descsize) + call psb_sum(ctxt,precsize) if (iam == psb_root_) then write(psb_out_unit,'(" ")') @@ -712,14 +754,14 @@ program psb_s_pde3d write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)')err write(psb_out_unit,'("Info on exit : ",i12)')info write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize - write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize + write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize write(psb_out_unit,'("Storage format for A: ",a)') a%get_fmt() write(psb_out_unit,'("Storage format for DESC_A: ",a)') desc_a%get_fmt() end if - ! + ! ! cleanup storage and exit ! call psb_gefree(bv,desc_a,info) @@ -734,10 +776,10 @@ program psb_s_pde3d goto 9999 end if - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop @@ -745,15 +787,17 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) - integer(psb_ipk_) :: ictxt + subroutine get_parms(ctxt,kmethd,ptype,afmt,idim,istopc,& + & itmax,itrace,irst,ipart,parms) + type(psb_ctxt_type) :: ctxt character(len=*) :: kmethd, ptype, afmt integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename + type(ainvparms) :: parms - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == 0) then if (command_argument_count()>0) then @@ -762,7 +806,7 @@ contains open(inp_unit,file=filename,action='read',iostat=info) if (info /= 0) then write(psb_err_unit,*) 'Could not open file ',filename,' for input' - call psb_abort(ictxt) + call psb_abort(ctxt) stop else write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' @@ -780,12 +824,12 @@ contains if (ip >= 4) then read(inp_unit,*) ipart else - ipart = 3 + ipart = 3 endif if (ip >= 5) then read(inp_unit,*) istopc else - istopc=1 + istopc=1 endif if (ip >= 6) then read(inp_unit,*) itmax @@ -802,8 +846,27 @@ contains else irst=1 endif + if (ip >= 9) then + read(inp_unit,*) parms%alg + read(inp_unit,*) parms%ilu_alg + read(inp_unit,*) parms%ilut_scale + read(inp_unit,*) parms%fill + read(inp_unit,*) parms%inv_fill + read(inp_unit,*) parms%thresh + read(inp_unit,*) parms%inv_thresh + read(inp_unit,*) parms%orth_alg + else + parms%alg = 'ILU' ! Block Solver ILU,ILUT,INVK,AINVT,AORTH + parms%ilu_alg = 'NONE' ! If ILU : MILU or NONE othewise ignored + parms%ilut_scale = 'NONE' ! If ILUT: NONE, MAXVAL, DIAG, ARWSUM, ACLSUM, ARCSUM + parms%fill = 0 ! Level of fill for forward factorization + parms%inv_fill = 1 ! Level of fill for inverse factorization (only INVK) + parms%thresh = 1E-1_psb_spk_ ! Threshold for forward factorization + parms%inv_thresh = 1E-1_psb_spk_ ! Threshold for inverse factorization + parms%orth_alg = 'LLK' ! What orthogonalization algorithm? + endif - write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,& & '("Grid dimensions : ",i4," x ",i4," x ",i4)') & & idim,idim,idim @@ -818,12 +881,41 @@ contains write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")') end select write(psb_out_unit,'("Preconditioner : ",a)') ptype + if( psb_toupper(ptype) == "BJAC" ) then + write(psb_out_unit,'("Block subsolver : ",a)') parms%alg + select case (psb_toupper(parms%alg)) + case ('ILU') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("MILU : ",a)') parms%ilu_alg + case ('ILUT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVK') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('INVT') + write(psb_out_unit,'("Fill in : ",i0)') parms%fill + write(psb_out_unit,'("Threshold : ",es12.5)') parms%thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case ('AINV','AORTH') + write(psb_out_unit,'("Inverse Threshold : ",es12.5)') parms%inv_thresh + write(psb_out_unit,'("Invese Fill in : ",i0)') parms%inv_fill + write(psb_out_unit,'("Orthogonalization : ",a)') parms%orth_alg + write(psb_out_unit,'("Scaling : ",a)') parms%ilut_scale + case default + write(psb_out_unit,'("Unknown diagonal solver")') + end select + end if write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') else ! wrong number of parameter, print an error message and exit - call pr_usage(izero) - call psb_abort(ictxt) + call pr_usage(izero) + call psb_abort(ctxt) stop 1 endif if (inp_unit /= psb_inp_unit) then @@ -832,29 +924,36 @@ contains end if ! broadcast parameters to all processors - call psb_bcast(ictxt,kmethd) - call psb_bcast(ictxt,afmt) - call psb_bcast(ictxt,ptype) - call psb_bcast(ictxt,idim) - call psb_bcast(ictxt,ipart) - call psb_bcast(ictxt,istopc) - call psb_bcast(ictxt,itmax) - call psb_bcast(ictxt,itrace) - call psb_bcast(ictxt,irst) + call psb_bcast(ctxt,kmethd) + call psb_bcast(ctxt,afmt) + call psb_bcast(ctxt,ptype) + call psb_bcast(ctxt,idim) + call psb_bcast(ctxt,ipart) + call psb_bcast(ctxt,istopc) + call psb_bcast(ctxt,itmax) + call psb_bcast(ctxt,itrace) + call psb_bcast(ctxt,irst) + call psb_bcast(ctxt,parms%alg) + call psb_bcast(ctxt,parms%fill) + call psb_bcast(ctxt,parms%inv_fill) + call psb_bcast(ctxt,parms%thresh) + call psb_bcast(ctxt,parms%inv_thresh) + call psb_bcast(ctxt,parms%orth_alg) + call psb_bcast(ctxt,parms%ilut_scale) return end subroutine get_parms ! - ! print an error message - ! + ! print an error message + ! subroutine pr_usage(iout) integer(psb_ipk_) :: iout write(iout,*)'incorrect parameter(s) found' write(iout,*)' usage: pde3d90 methd prec dim & - &[istop itmax itrace]' + &[istop itmax itrace]' write(iout,*)' where:' - write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' write(iout,*)' prec : bjac diag none' write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' @@ -862,11 +961,9 @@ contains write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' - write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' itrace <=0 (no tracing, default) or ' write(iout,*)' >= 1 do tracing every itrace' - write(iout,*)' iterations ' + write(iout,*)' iterations ' end subroutine pr_usage end program psb_s_pde3d - - diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index f6fe33eb..f4b45430 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -1,4 +1,4 @@ -8 Number of entries below this +17 Number of entries below this BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES FCG CGR BJAC Preconditioner NONE DIAG BJAC CSR Storage format for matrix A: CSR COO @@ -8,5 +8,11 @@ CSR Storage format for matrix A: CSR COO 0100 MAXIT 05 ITRACE 002 IRST restart for RGMRES and BiCGSTABL - - +ILU Block Solver ILU,ILUT,INVK,AINVT,AORTH +NONE If ILU : MILU or NONE othewise ignored +NONE Scaling if ILUT: NONE, MAXVAL otherwise ignored +0 Level of fill for forward factorization +1 Level of fill for inverse factorization (only INVK) +1E-1 Threshold for forward factorization +1E-1 Threshold for inverse factorization (Only INVK, AINVT) +LLK What orthogonalization algorithm? (Only AINVT) diff --git a/test/serial/d_matgen.F90 b/test/serial/d_matgen.F90 index ab41f790..5d6cd18e 100644 --- a/test/serial/d_matgen.F90 +++ b/test/serial/d_matgen.F90 @@ -34,7 +34,7 @@ contains ! subroutine to allocate and fill in the coefficient matrix and ! the rhs. ! - subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,& + subroutine psb_d_gen_pde3d(ctxt,idim,a,bv,xv,desc_a,afmt,& & a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,imold,nrl,iv) use psb_base_mod ! @@ -58,7 +58,8 @@ contains type(psb_dspmat_type) :: a type(psb_d_vect_type) :: xv,bv type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, info + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: info character(len=*) :: afmt procedure(d_func_3d), optional :: f class(psb_d_base_sparse_mat), optional :: amold @@ -92,7 +93,7 @@ contains name = 'create_matrix' call psb_erractionsave(err_act) - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (present(f)) then @@ -125,30 +126,30 @@ contains end if nt = nr - call psb_sum(ictxt,nt) + call psb_sum(ctxt,nt) if (nt /= m) then write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if else if (size(iv) /= m) then write(psb_err_unit,*) iam, 'Initialization error IV',size(iv),m info = -1 - call psb_barrier(ictxt) - call psb_abort(ictxt) + call psb_barrier(ctxt) + call psb_abort(ctxt) return end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() if (present(iv)) then - call psb_cdall(ictxt,desc_a,info,vg=iv) + call psb_cdall(ctxt,desc_a,info,vg=iv) else - call psb_cdall(ictxt,desc_a,info,nl=nr) + call psb_cdall(ctxt,desc_a,info,nl=nr) end if if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) @@ -156,7 +157,7 @@ contains if (info == psb_success_) call psb_geall(xv,desc_a,info) if (info == psb_success_) call psb_geall(bv,desc_a,info) - call psb_barrier(ictxt) + call psb_barrier(ctxt) talc = psb_wtime()-t0 if (info /= psb_success_) then @@ -184,7 +185,7 @@ contains ! loop over rows belonging to current process in a block ! distribution. - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() do ii=1, nlr,nb ib = min(nb,nlr-ii+1) @@ -295,11 +296,11 @@ contains deallocate(val,irow,icol) - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() call psb_cdasb(desc_a,info,mold=imold) tcdasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() if (info == psb_success_) then if (present(amold)) then @@ -308,7 +309,7 @@ contains call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) end if end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='asb rout.' @@ -324,13 +325,13 @@ contains goto 9999 end if tasb = psb_wtime()-t1 - call psb_barrier(ictxt) + call psb_barrier(ctxt) ttot = psb_wtime() - t0 - call psb_amx(ictxt,talc) - call psb_amx(ictxt,tgen) - call psb_amx(ictxt,tasb) - call psb_amx(ictxt,ttot) + call psb_amx(ctxt,talc) + call psb_amx(ctxt,tgen) + call psb_amx(ctxt,tasb) + call psb_amx(ctxt,ttot) if(iam == psb_root_) then tmpfmt = a%get_fmt() write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& @@ -345,7 +346,7 @@ contains call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return end subroutine psb_d_gen_pde3d @@ -377,7 +378,8 @@ program d_matgen ! dense matrices type(psb_d_vect_type) :: b, x ! blacs parameters - integer(psb_ipk_) :: ictxt, iam, np + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam, np ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst @@ -392,12 +394,12 @@ program d_matgen info=psb_success_ - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if (iam < 0) then ! This should not happen, but just in case - call psb_exit(ictxt) + call psb_exit(ctxt) stop endif if(psb_get_errstatus() /= 0) goto 9999 @@ -407,29 +409,29 @@ program d_matgen ! ! get parameters ! - call get_parms(ictxt,idim) + call get_parms(ctxt,idim) ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! - call psb_barrier(ictxt) + call psb_barrier(ctxt) t1 = psb_wtime() if (.false.) then - call psb_gen_pde3d(ictxt,idim,a,b,x,desc_a,afmt,& + call psb_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& & a1,a2,a3,b1,b2,b3,c,g,info,amold=acsr) else if (.false.) then - call psb_gen_pde3d(ictxt,idim,a,b,x,desc_a,afmt,& + call psb_gen_pde3d(ctxt,idim,a,b,x,desc_a,afmt,& & a1,a2,a3,b1,b2,b3,c,g,info,amold=axyz) end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() - t1 - call psb_exit(ictxt) + call psb_exit(ctxt) stop -9999 call psb_error(ictxt) +9999 call psb_error(ctxt) stop @@ -437,13 +439,13 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,idim) - integer(psb_ipk_) :: ictxt + subroutine get_parms(ctxt,idim) + type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: idim integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: intbuf(10), ip - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) read(psb_inp_unit,*) idim diff --git a/test/torture/psb_c_mvsv_tester.f90 b/test/torture/psb_c_mvsv_tester.f90 index f1f72183..ed6a9423 100644 --- a/test/torture/psb_c_mvsv_tester.f90 +++ b/test/torture/psb_c_mvsv_tester.f90 @@ -1,13 +1,14 @@ module psb_c_mvsv_tester contains - subroutine c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -33,17 +34,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -77,13 +78,14 @@ contains end subroutine c_usmv_2_n_ap3_bp1_ix1_iy1 ! - subroutine c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -109,17 +111,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -153,13 +155,14 @@ contains end subroutine c_usmv_2_t_ap3_bp1_ix1_iy1 ! - subroutine c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -185,17 +188,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -229,13 +232,14 @@ contains end subroutine c_usmv_2_c_ap3_bp1_ix1_iy1 ! - subroutine c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -261,17 +265,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -305,13 +309,14 @@ contains end subroutine c_usmv_2_n_ap3_bm0_ix1_iy1 ! - subroutine c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -337,17 +342,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -381,13 +386,14 @@ contains end subroutine c_usmv_2_t_ap3_bm0_ix1_iy1 ! - subroutine c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -413,17 +419,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -457,13 +463,14 @@ contains end subroutine c_usmv_2_c_ap3_bm0_ix1_iy1 ! - subroutine c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -489,17 +496,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -533,13 +540,14 @@ contains end subroutine c_usmv_2_n_ap1_bp1_ix1_iy1 ! - subroutine c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -565,17 +573,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -609,13 +617,14 @@ contains end subroutine c_usmv_2_t_ap1_bp1_ix1_iy1 ! - subroutine c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -641,17 +650,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -685,13 +694,14 @@ contains end subroutine c_usmv_2_c_ap1_bp1_ix1_iy1 ! - subroutine c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -717,17 +727,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -761,13 +771,14 @@ contains end subroutine c_usmv_2_n_ap1_bm0_ix1_iy1 ! - subroutine c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -793,17 +804,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -837,13 +848,14 @@ contains end subroutine c_usmv_2_t_ap1_bm0_ix1_iy1 ! - subroutine c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -869,17 +881,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -913,13 +925,14 @@ contains end subroutine c_usmv_2_c_ap1_bm0_ix1_iy1 ! - subroutine c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -945,17 +958,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -989,13 +1002,14 @@ contains end subroutine c_usmv_2_n_am1_bp1_ix1_iy1 ! - subroutine c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1021,17 +1035,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1065,13 +1079,14 @@ contains end subroutine c_usmv_2_t_am1_bp1_ix1_iy1 ! - subroutine c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1097,17 +1112,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1141,13 +1156,14 @@ contains end subroutine c_usmv_2_c_am1_bp1_ix1_iy1 ! - subroutine c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1173,17 +1189,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1217,13 +1233,14 @@ contains end subroutine c_usmv_2_n_am1_bm0_ix1_iy1 ! - subroutine c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1249,17 +1266,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1293,13 +1310,14 @@ contains end subroutine c_usmv_2_t_am1_bm0_ix1_iy1 ! - subroutine c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1325,17 +1343,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1369,13 +1387,14 @@ contains end subroutine c_usmv_2_c_am1_bm0_ix1_iy1 ! - subroutine c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1401,17 +1420,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1445,13 +1464,14 @@ contains end subroutine c_usmv_2_n_am3_bp1_ix1_iy1 ! - subroutine c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1477,17 +1497,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1521,13 +1541,14 @@ contains end subroutine c_usmv_2_t_am3_bp1_ix1_iy1 ! - subroutine c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1553,17 +1574,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1597,13 +1618,14 @@ contains end subroutine c_usmv_2_c_am3_bp1_ix1_iy1 ! - subroutine c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1629,17 +1651,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1673,13 +1695,14 @@ contains end subroutine c_usmv_2_n_am3_bm0_ix1_iy1 ! - subroutine c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1705,17 +1728,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1749,13 +1772,14 @@ contains end subroutine c_usmv_2_t_am3_bm0_ix1_iy1 ! - subroutine c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1781,17 +1805,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1825,13 +1849,14 @@ contains end subroutine c_usmv_2_c_am3_bm0_ix1_iy1 ! - subroutine c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1856,13 +1881,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -1870,7 +1895,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1904,13 +1929,14 @@ contains end subroutine c_ussv_2_n_ap3_bm0_ix1_iy1 ! - subroutine c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1935,13 +1961,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -1949,7 +1975,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1983,13 +2009,14 @@ contains end subroutine c_ussv_2_t_ap3_bm0_ix1_iy1 ! - subroutine c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2014,13 +2041,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2028,7 +2055,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2062,13 +2089,14 @@ contains end subroutine c_ussv_2_c_ap3_bm0_ix1_iy1 ! - subroutine c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2093,13 +2121,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2107,7 +2135,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2141,13 +2169,14 @@ contains end subroutine c_ussv_2_n_ap1_bm0_ix1_iy1 ! - subroutine c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2172,13 +2201,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2186,7 +2215,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2220,13 +2249,14 @@ contains end subroutine c_ussv_2_t_ap1_bm0_ix1_iy1 ! - subroutine c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2251,13 +2281,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2265,7 +2295,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2299,13 +2329,14 @@ contains end subroutine c_ussv_2_c_ap1_bm0_ix1_iy1 ! - subroutine c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2330,13 +2361,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2344,7 +2375,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2378,13 +2409,14 @@ contains end subroutine c_ussv_2_n_am1_bm0_ix1_iy1 ! - subroutine c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2409,13 +2441,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2423,7 +2455,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2457,13 +2489,14 @@ contains end subroutine c_ussv_2_t_am1_bm0_ix1_iy1 ! - subroutine c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2488,13 +2521,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2502,7 +2535,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2536,13 +2569,14 @@ contains end subroutine c_ussv_2_c_am1_bm0_ix1_iy1 ! - subroutine c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2567,13 +2601,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2581,7 +2615,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2615,13 +2649,14 @@ contains end subroutine c_ussv_2_n_am3_bm0_ix1_iy1 ! - subroutine c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2646,13 +2681,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2660,7 +2695,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2694,13 +2729,14 @@ contains end subroutine c_ussv_2_t_am3_bm0_ix1_iy1 ! - subroutine c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2725,13 +2761,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2739,7 +2775,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) diff --git a/test/torture/psb_d_mvsv_tester.f90 b/test/torture/psb_d_mvsv_tester.f90 index 44d11336..baabf216 100644 --- a/test/torture/psb_d_mvsv_tester.f90 +++ b/test/torture/psb_d_mvsv_tester.f90 @@ -2,13 +2,14 @@ module psb_d_mvsv_tester contains - subroutine d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -34,17 +35,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -78,13 +79,14 @@ contains end subroutine d_usmv_2_n_ap3_bp1_ix1_iy1 ! - subroutine d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -110,17 +112,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -154,13 +156,14 @@ contains end subroutine d_usmv_2_t_ap3_bp1_ix1_iy1 ! - subroutine d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -186,17 +189,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -230,13 +233,14 @@ contains end subroutine d_usmv_2_c_ap3_bp1_ix1_iy1 ! - subroutine d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -262,17 +266,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -306,13 +310,14 @@ contains end subroutine d_usmv_2_n_ap3_bm0_ix1_iy1 ! - subroutine d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -338,17 +343,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -382,13 +387,14 @@ contains end subroutine d_usmv_2_t_ap3_bm0_ix1_iy1 ! - subroutine d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -414,17 +420,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -458,13 +464,14 @@ contains end subroutine d_usmv_2_c_ap3_bm0_ix1_iy1 ! - subroutine d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -490,17 +497,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -534,13 +541,14 @@ contains end subroutine d_usmv_2_n_ap1_bp1_ix1_iy1 ! - subroutine d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -566,17 +574,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -610,13 +618,14 @@ contains end subroutine d_usmv_2_t_ap1_bp1_ix1_iy1 ! - subroutine d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -642,17 +651,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -686,13 +695,14 @@ contains end subroutine d_usmv_2_c_ap1_bp1_ix1_iy1 ! - subroutine d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -718,17 +728,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -762,13 +772,14 @@ contains end subroutine d_usmv_2_n_ap1_bm0_ix1_iy1 ! - subroutine d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -794,17 +805,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -838,13 +849,14 @@ contains end subroutine d_usmv_2_t_ap1_bm0_ix1_iy1 ! - subroutine d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -870,17 +882,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -914,13 +926,14 @@ contains end subroutine d_usmv_2_c_ap1_bm0_ix1_iy1 ! - subroutine d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -946,17 +959,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -990,13 +1003,14 @@ contains end subroutine d_usmv_2_n_am1_bp1_ix1_iy1 ! - subroutine d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1022,17 +1036,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1066,13 +1080,14 @@ contains end subroutine d_usmv_2_t_am1_bp1_ix1_iy1 ! - subroutine d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1098,17 +1113,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1142,13 +1157,14 @@ contains end subroutine d_usmv_2_c_am1_bp1_ix1_iy1 ! - subroutine d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1174,17 +1190,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1218,13 +1234,14 @@ contains end subroutine d_usmv_2_n_am1_bm0_ix1_iy1 ! - subroutine d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1250,17 +1267,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1294,13 +1311,14 @@ contains end subroutine d_usmv_2_t_am1_bm0_ix1_iy1 ! - subroutine d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1326,17 +1344,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1370,13 +1388,14 @@ contains end subroutine d_usmv_2_c_am1_bm0_ix1_iy1 ! - subroutine d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1402,17 +1421,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1446,13 +1465,14 @@ contains end subroutine d_usmv_2_n_am3_bp1_ix1_iy1 ! - subroutine d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1478,17 +1498,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1522,13 +1542,14 @@ contains end subroutine d_usmv_2_t_am3_bp1_ix1_iy1 ! - subroutine d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1554,17 +1575,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1598,13 +1619,14 @@ contains end subroutine d_usmv_2_c_am3_bp1_ix1_iy1 ! - subroutine d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1630,17 +1652,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1674,13 +1696,14 @@ contains end subroutine d_usmv_2_n_am3_bm0_ix1_iy1 ! - subroutine d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1706,17 +1729,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1750,13 +1773,14 @@ contains end subroutine d_usmv_2_t_am3_bm0_ix1_iy1 ! - subroutine d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1782,17 +1806,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1826,13 +1850,14 @@ contains end subroutine d_usmv_2_c_am3_bm0_ix1_iy1 ! - subroutine d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1857,13 +1882,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -1871,7 +1896,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1905,13 +1930,14 @@ contains end subroutine d_ussv_2_n_ap3_bm0_ix1_iy1 ! - subroutine d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1936,13 +1962,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -1950,7 +1976,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1984,13 +2010,14 @@ contains end subroutine d_ussv_2_t_ap3_bm0_ix1_iy1 ! - subroutine d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2015,13 +2042,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2029,7 +2056,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2063,13 +2090,14 @@ contains end subroutine d_ussv_2_c_ap3_bm0_ix1_iy1 ! - subroutine d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2094,13 +2122,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2108,7 +2136,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2142,13 +2170,14 @@ contains end subroutine d_ussv_2_n_ap1_bm0_ix1_iy1 ! - subroutine d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2173,13 +2202,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2187,7 +2216,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2221,13 +2250,14 @@ contains end subroutine d_ussv_2_t_ap1_bm0_ix1_iy1 ! - subroutine d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2252,13 +2282,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2266,7 +2296,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2300,13 +2330,14 @@ contains end subroutine d_ussv_2_c_ap1_bm0_ix1_iy1 ! - subroutine d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2331,13 +2362,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2345,7 +2376,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2379,13 +2410,14 @@ contains end subroutine d_ussv_2_n_am1_bm0_ix1_iy1 ! - subroutine d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2410,13 +2442,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2424,7 +2456,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2458,13 +2490,14 @@ contains end subroutine d_ussv_2_t_am1_bm0_ix1_iy1 ! - subroutine d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2489,13 +2522,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2503,7 +2536,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2537,13 +2570,14 @@ contains end subroutine d_ussv_2_c_am1_bm0_ix1_iy1 ! - subroutine d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2568,13 +2602,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2582,7 +2616,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2616,13 +2650,14 @@ contains end subroutine d_ussv_2_n_am3_bm0_ix1_iy1 ! - subroutine d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2647,13 +2682,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2661,7 +2696,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2695,13 +2730,14 @@ contains end subroutine d_ussv_2_t_am3_bm0_ix1_iy1 ! - subroutine d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2726,13 +2762,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2740,7 +2776,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) diff --git a/test/torture/psb_s_mvsv_tester.f90 b/test/torture/psb_s_mvsv_tester.f90 index 8203067e..34c1e9eb 100644 --- a/test/torture/psb_s_mvsv_tester.f90 +++ b/test/torture/psb_s_mvsv_tester.f90 @@ -1,12 +1,13 @@ module psb_s_mvsv_tester contains - subroutine s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -32,17 +33,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -76,13 +77,14 @@ contains end subroutine s_usmv_2_n_ap3_bp1_ix1_iy1 ! - subroutine s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -108,17 +110,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -152,13 +154,14 @@ contains end subroutine s_usmv_2_t_ap3_bp1_ix1_iy1 ! - subroutine s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -184,17 +187,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -228,13 +231,14 @@ contains end subroutine s_usmv_2_c_ap3_bp1_ix1_iy1 ! - subroutine s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -260,17 +264,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -304,13 +308,14 @@ contains end subroutine s_usmv_2_n_ap3_bm0_ix1_iy1 ! - subroutine s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -336,17 +341,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -380,13 +385,14 @@ contains end subroutine s_usmv_2_t_ap3_bm0_ix1_iy1 ! - subroutine s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -412,17 +418,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -456,13 +462,14 @@ contains end subroutine s_usmv_2_c_ap3_bm0_ix1_iy1 ! - subroutine s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -488,17 +495,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -532,13 +539,14 @@ contains end subroutine s_usmv_2_n_ap1_bp1_ix1_iy1 ! - subroutine s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -564,17 +572,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -608,13 +616,14 @@ contains end subroutine s_usmv_2_t_ap1_bp1_ix1_iy1 ! - subroutine s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -640,17 +649,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -684,13 +693,14 @@ contains end subroutine s_usmv_2_c_ap1_bp1_ix1_iy1 ! - subroutine s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -716,17 +726,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -760,13 +770,14 @@ contains end subroutine s_usmv_2_n_ap1_bm0_ix1_iy1 ! - subroutine s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -792,17 +803,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -836,13 +847,14 @@ contains end subroutine s_usmv_2_t_ap1_bm0_ix1_iy1 ! - subroutine s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -868,17 +880,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -912,13 +924,14 @@ contains end subroutine s_usmv_2_c_ap1_bm0_ix1_iy1 ! - subroutine s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -944,17 +957,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -988,13 +1001,14 @@ contains end subroutine s_usmv_2_n_am1_bp1_ix1_iy1 ! - subroutine s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1020,17 +1034,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1064,13 +1078,14 @@ contains end subroutine s_usmv_2_t_am1_bp1_ix1_iy1 ! - subroutine s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1096,17 +1111,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1140,13 +1155,14 @@ contains end subroutine s_usmv_2_c_am1_bp1_ix1_iy1 ! - subroutine s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1172,17 +1188,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1216,13 +1232,14 @@ contains end subroutine s_usmv_2_n_am1_bm0_ix1_iy1 ! - subroutine s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1248,17 +1265,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1292,13 +1309,14 @@ contains end subroutine s_usmv_2_t_am1_bm0_ix1_iy1 ! - subroutine s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1324,17 +1342,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1368,13 +1386,14 @@ contains end subroutine s_usmv_2_c_am1_bm0_ix1_iy1 ! - subroutine s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1400,17 +1419,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1444,13 +1463,14 @@ contains end subroutine s_usmv_2_n_am3_bp1_ix1_iy1 ! - subroutine s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1476,17 +1496,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1520,13 +1540,14 @@ contains end subroutine s_usmv_2_t_am3_bp1_ix1_iy1 ! - subroutine s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1552,17 +1573,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1596,13 +1617,14 @@ contains end subroutine s_usmv_2_c_am3_bp1_ix1_iy1 ! - subroutine s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1628,17 +1650,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1672,13 +1694,14 @@ contains end subroutine s_usmv_2_n_am3_bm0_ix1_iy1 ! - subroutine s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1704,17 +1727,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1748,13 +1771,14 @@ contains end subroutine s_usmv_2_t_am3_bm0_ix1_iy1 ! - subroutine s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1780,17 +1804,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1824,13 +1848,14 @@ contains end subroutine s_usmv_2_c_am3_bm0_ix1_iy1 ! - subroutine s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1855,20 +1880,20 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1902,13 +1927,14 @@ contains end subroutine s_ussv_2_n_ap3_bm0_ix1_iy1 ! - subroutine s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1933,13 +1959,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -1947,7 +1973,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1981,13 +2007,14 @@ contains end subroutine s_ussv_2_t_ap3_bm0_ix1_iy1 ! - subroutine s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2012,13 +2039,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2026,7 +2053,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2060,13 +2087,14 @@ contains end subroutine s_ussv_2_c_ap3_bm0_ix1_iy1 ! - subroutine s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2091,13 +2119,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2105,7 +2133,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2139,13 +2167,14 @@ contains end subroutine s_ussv_2_n_ap1_bm0_ix1_iy1 ! - subroutine s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2170,13 +2199,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2184,7 +2213,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2218,13 +2247,14 @@ contains end subroutine s_ussv_2_t_ap1_bm0_ix1_iy1 ! - subroutine s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2249,13 +2279,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2263,7 +2293,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2297,13 +2327,14 @@ contains end subroutine s_ussv_2_c_ap1_bm0_ix1_iy1 ! - subroutine s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2328,13 +2359,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2342,7 +2373,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2376,13 +2407,14 @@ contains end subroutine s_ussv_2_n_am1_bm0_ix1_iy1 ! - subroutine s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2407,13 +2439,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2421,7 +2453,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2455,13 +2487,14 @@ contains end subroutine s_ussv_2_t_am1_bm0_ix1_iy1 ! - subroutine s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2486,13 +2519,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2500,7 +2533,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2534,13 +2567,14 @@ contains end subroutine s_ussv_2_c_am1_bm0_ix1_iy1 ! - subroutine s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2565,13 +2599,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2579,7 +2613,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2613,13 +2647,14 @@ contains end subroutine s_ussv_2_n_am3_bm0_ix1_iy1 ! - subroutine s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2644,13 +2679,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2658,7 +2693,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2692,13 +2727,14 @@ contains end subroutine s_ussv_2_t_am3_bm0_ix1_iy1 ! - subroutine s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2723,13 +2759,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2737,7 +2773,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) diff --git a/test/torture/psb_z_mvsv_tester.f90 b/test/torture/psb_z_mvsv_tester.f90 index 11c4b766..bc84a447 100644 --- a/test/torture/psb_z_mvsv_tester.f90 +++ b/test/torture/psb_z_mvsv_tester.f90 @@ -1,13 +1,14 @@ module psb_z_mvsv_tester contains - subroutine z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -33,17 +34,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -77,13 +78,14 @@ contains end subroutine z_usmv_2_n_ap3_bp1_ix1_iy1 ! - subroutine z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -109,17 +111,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -153,13 +155,14 @@ contains end subroutine z_usmv_2_t_ap3_bp1_ix1_iy1 ! - subroutine z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -185,17 +188,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -229,13 +232,14 @@ contains end subroutine z_usmv_2_c_ap3_bp1_ix1_iy1 ! - subroutine z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -261,17 +265,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -305,13 +309,14 @@ contains end subroutine z_usmv_2_n_ap3_bm0_ix1_iy1 ! - subroutine z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -337,17 +342,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -381,13 +386,14 @@ contains end subroutine z_usmv_2_t_ap3_bm0_ix1_iy1 ! - subroutine z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -413,17 +419,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -457,13 +463,14 @@ contains end subroutine z_usmv_2_c_ap3_bm0_ix1_iy1 ! - subroutine z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -489,17 +496,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -533,13 +540,14 @@ contains end subroutine z_usmv_2_n_ap1_bp1_ix1_iy1 ! - subroutine z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -565,17 +573,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -609,13 +617,14 @@ contains end subroutine z_usmv_2_t_ap1_bp1_ix1_iy1 ! - subroutine z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -641,17 +650,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -685,13 +694,14 @@ contains end subroutine z_usmv_2_c_ap1_bp1_ix1_iy1 ! - subroutine z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -717,17 +727,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -761,13 +771,14 @@ contains end subroutine z_usmv_2_n_ap1_bm0_ix1_iy1 ! - subroutine z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -793,17 +804,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -837,13 +848,14 @@ contains end subroutine z_usmv_2_t_ap1_bm0_ix1_iy1 ! - subroutine z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -869,17 +881,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -913,13 +925,14 @@ contains end subroutine z_usmv_2_c_ap1_bm0_ix1_iy1 ! - subroutine z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -945,17 +958,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -989,13 +1002,14 @@ contains end subroutine z_usmv_2_n_am1_bp1_ix1_iy1 ! - subroutine z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1021,17 +1035,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1065,13 +1079,14 @@ contains end subroutine z_usmv_2_t_am1_bp1_ix1_iy1 ! - subroutine z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1097,17 +1112,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1141,13 +1156,14 @@ contains end subroutine z_usmv_2_c_am1_bp1_ix1_iy1 ! - subroutine z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1173,17 +1189,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1217,13 +1233,14 @@ contains end subroutine z_usmv_2_n_am1_bm0_ix1_iy1 ! - subroutine z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1249,17 +1266,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1293,13 +1310,14 @@ contains end subroutine z_usmv_2_t_am1_bm0_ix1_iy1 ! - subroutine z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1325,17 +1343,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1369,13 +1387,14 @@ contains end subroutine z_usmv_2_c_am1_bm0_ix1_iy1 ! - subroutine z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1401,17 +1420,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1445,13 +1464,14 @@ contains end subroutine z_usmv_2_n_am3_bp1_ix1_iy1 ! - subroutine z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1477,17 +1497,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1521,13 +1541,14 @@ contains end subroutine z_usmv_2_t_am3_bp1_ix1_iy1 ! - subroutine z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1553,17 +1574,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1597,13 +1618,14 @@ contains end subroutine z_usmv_2_c_am3_bp1_ix1_iy1 ! - subroutine z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1629,17 +1651,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1673,13 +1695,14 @@ contains end subroutine z_usmv_2_n_am3_bm0_ix1_iy1 ! - subroutine z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1705,17 +1728,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1749,13 +1772,14 @@ contains end subroutine z_usmv_2_t_am3_bm0_ix1_iy1 ! - subroutine z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1781,17 +1805,17 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1825,13 +1849,14 @@ contains end subroutine z_usmv_2_c_am3_bm0_ix1_iy1 ! - subroutine z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1856,13 +1881,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -1870,7 +1895,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1904,13 +1929,14 @@ contains end subroutine z_ussv_2_n_ap3_bm0_ix1_iy1 ! - subroutine z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -1935,13 +1961,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -1949,7 +1975,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -1983,13 +2009,14 @@ contains end subroutine z_ussv_2_t_ap3_bm0_ix1_iy1 ! - subroutine z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2014,13 +2041,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2028,7 +2055,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2062,13 +2089,14 @@ contains end subroutine z_ussv_2_c_ap3_bm0_ix1_iy1 ! - subroutine z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2093,13 +2121,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2107,7 +2135,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2141,13 +2169,14 @@ contains end subroutine z_ussv_2_n_ap1_bm0_ix1_iy1 ! - subroutine z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2172,13 +2201,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2186,7 +2215,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2220,13 +2249,14 @@ contains end subroutine z_ussv_2_t_ap1_bm0_ix1_iy1 ! - subroutine z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2251,13 +2281,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2265,7 +2295,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2299,13 +2329,14 @@ contains end subroutine z_ussv_2_c_ap1_bm0_ix1_iy1 ! - subroutine z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2330,13 +2361,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2344,7 +2375,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2378,13 +2409,14 @@ contains end subroutine z_ussv_2_n_am1_bm0_ix1_iy1 ! - subroutine z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2409,13 +2441,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2423,7 +2455,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2457,13 +2489,14 @@ contains end subroutine z_ussv_2_t_am1_bm0_ix1_iy1 ! - subroutine z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2488,13 +2521,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2502,7 +2535,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2536,13 +2569,14 @@ contains end subroutine z_ussv_2_c_am1_bm0_ix1_iy1 ! - subroutine z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2567,13 +2601,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2581,7 +2615,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2615,13 +2649,14 @@ contains end subroutine z_ussv_2_n_am3_bm0_ix1_iy1 ! - subroutine z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2646,13 +2681,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2660,7 +2695,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) @@ -2694,13 +2729,14 @@ contains end subroutine z_ussv_2_t_am3_bm0_ix1_iy1 ! - subroutine z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + subroutine z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) use psb_base_mod implicit none character(len=*) :: afmt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: iam=-1, np=-1 integer(psb_ipk_) :: info=-1 integer(psb_ipk_) ::res,istat=0,i @@ -2725,13 +2761,13 @@ contains y=bcy res=0 - call psb_info(ictxt,iam,np) + call psb_info(ctxt,iam,np) if(iam<0)then info=-1 goto 9999 endif - call psb_barrier(ictxt) - call psb_cdall(ictxt,desc_a,info,nl=m) + call psb_barrier(ctxt) + call psb_cdall(ctxt,desc_a,info,nl=m) if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) if (info /= psb_success_)goto 9996 @@ -2739,7 +2775,7 @@ contains call a%set_lower() call a%set_unit(.false.) - call psb_barrier(ictxt) + call psb_barrier(ctxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) diff --git a/test/torture/psbtf.f90 b/test/torture/psbtf.f90 index 886bcb07..35851ada 100644 --- a/test/torture/psbtf.f90 +++ b/test/torture/psbtf.f90 @@ -11,734 +11,734 @@ program main implicit none integer(psb_ipk_), parameter :: psb_fidasize_=16 integer(psb_ipk_) :: res,passed=0,failed=0; - integer(psb_ipk_) :: ictxt, iam=-1, np=-1 + integer(psb_ipk_) :: ctxt, iam=-1, np=-1 character(len=psb_fidasize_) :: afmt write(psb_out_unit,*) 'Format ?' read(psb_inp_unit,*) afmt ! afmt = 'COO' - call psb_init(ictxt) - call psb_info(ictxt,iam,np) + call psb_init(ctxt) + call psb_info(ctxt,iam,np) if(iam<0)then goto 9999 endif - call s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 - call z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) + call z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ctxt) if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 @@ -746,7 +746,7 @@ program main 9999 continue print *,"PASSED:",passed print *,"FAILED:",failed - call psb_exit(ictxt) + call psb_exit(ctxt) end program main diff --git a/util/psb_c_mat_dist_impl.f90 b/util/psb_c_mat_dist_impl.f90 index 7767ce2e..970dfc47 100644 --- a/util/psb_c_mat_dist_impl.f90 +++ b/util/psb_c_mat_dist_impl.f90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& +subroutine psb_cmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -59,7 +59,7 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -75,7 +75,7 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_cspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -110,7 +110,7 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) use_parts = present(parts) use_vg = present(vg) @@ -140,10 +140,10 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -156,11 +156,11 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -269,12 +269,12 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -282,8 +282,8 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -296,10 +296,10 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -319,7 +319,7 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -330,7 +330,7 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -362,7 +362,7 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -370,7 +370,7 @@ end subroutine psb_cmatdist -subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& +subroutine psb_lcmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -400,7 +400,7 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -416,7 +416,7 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_lcspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -452,7 +452,7 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == root) then nrow = a_glob%get_nrows() ncol = a_glob%get_ncols() @@ -476,10 +476,10 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -492,11 +492,11 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -607,12 +607,12 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -620,8 +620,8 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -634,10 +634,10 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) il = ll call psb_spins(il,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then @@ -658,7 +658,7 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -669,7 +669,7 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -701,7 +701,7 @@ subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/util/psb_c_mat_dist_mod.f90 b/util/psb_c_mat_dist_mod.f90 index c46efd2f..de48dabf 100644 --- a/util/psb_c_mat_dist_mod.f90 +++ b/util/psb_c_mat_dist_mod.f90 @@ -32,10 +32,10 @@ module psb_c_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_spk_, psb_desc_type, psb_parts, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_vect_type, & - & psb_lcspmat_type + & psb_lcspmat_type, psb_ctxt_type interface psb_matdist - subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_cmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -65,7 +65,7 @@ module psb_c_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -76,13 +76,12 @@ module psb_c_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_desc_type,& - & psb_c_base_sparse_mat, psb_c_vect_type, psb_parts + import implicit none ! parameters type(psb_cspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -93,7 +92,7 @@ module psb_c_mat_dist_mod integer(psb_ipk_), optional :: vg(:) integer(psb_ipk_), optional :: vsz(:) end subroutine psb_cmatdist - subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_lcmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -123,7 +122,7 @@ module psb_c_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -134,14 +133,12 @@ module psb_c_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_desc_type,& - & psb_c_base_sparse_mat, psb_c_vect_type, psb_parts, & - & psb_lcspmat_type + import implicit none ! parameters type(psb_lcspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_cspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info diff --git a/util/psb_d_mat_dist_impl.f90 b/util/psb_d_mat_dist_impl.f90 index 17df5f69..c71141f0 100644 --- a/util/psb_d_mat_dist_impl.f90 +++ b/util/psb_d_mat_dist_impl.f90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& +subroutine psb_dmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -59,7 +59,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -75,7 +75,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_dspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -110,7 +110,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) use_parts = present(parts) use_vg = present(vg) @@ -140,10 +140,10 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -156,11 +156,11 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -269,12 +269,12 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -282,8 +282,8 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -296,10 +296,10 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -319,7 +319,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -330,7 +330,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -362,7 +362,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -370,7 +370,7 @@ end subroutine psb_dmatdist -subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& +subroutine psb_ldmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -400,7 +400,7 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -416,7 +416,7 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_ldspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -452,7 +452,7 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == root) then nrow = a_glob%get_nrows() ncol = a_glob%get_ncols() @@ -476,10 +476,10 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -492,11 +492,11 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -607,12 +607,12 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -620,8 +620,8 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -634,10 +634,10 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) il = ll call psb_spins(il,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then @@ -658,7 +658,7 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -669,7 +669,7 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -701,7 +701,7 @@ subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/util/psb_d_mat_dist_mod.f90 b/util/psb_d_mat_dist_mod.f90 index dc0e4958..2c7f9290 100644 --- a/util/psb_d_mat_dist_mod.f90 +++ b/util/psb_d_mat_dist_mod.f90 @@ -32,10 +32,10 @@ module psb_d_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_dpk_, psb_desc_type, psb_parts, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_vect_type, & - & psb_ldspmat_type + & psb_ldspmat_type, psb_ctxt_type interface psb_matdist - subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_dmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -65,7 +65,7 @@ module psb_d_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -76,13 +76,12 @@ module psb_d_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_desc_type,& - & psb_d_base_sparse_mat, psb_d_vect_type, psb_parts + import implicit none ! parameters type(psb_dspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -93,7 +92,7 @@ module psb_d_mat_dist_mod integer(psb_ipk_), optional :: vg(:) integer(psb_ipk_), optional :: vsz(:) end subroutine psb_dmatdist - subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_ldmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -123,7 +122,7 @@ module psb_d_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -134,14 +133,12 @@ module psb_d_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_desc_type,& - & psb_d_base_sparse_mat, psb_d_vect_type, psb_parts, & - & psb_ldspmat_type + import implicit none ! parameters type(psb_ldspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_dspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info diff --git a/util/psb_metispart_mod.F90 b/util/psb_metispart_mod.F90 index 081d1bc1..69dae5a8 100644 --- a/util/psb_metispart_mod.F90 +++ b/util/psb_metispart_mod.F90 @@ -45,7 +45,7 @@ ! integer(psb_ipk_) :: NPARTS How many parts we are requiring to the ! partition utility ! -! DISTR_MTPART(ROOT,ICTXT): This subroutine will be called by +! DISTR_MTPART(ROOT,ctxt): This subroutine will be called by ! all processes to distribute the information computed by the root ! process, to be used subsequently. ! @@ -55,7 +55,7 @@ ! module psb_metispart_mod use psb_base_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, & - & psb_err_unit, psb_spk_, psb_dpk_,& + & psb_err_unit, psb_spk_, psb_dpk_, psb_ctxt_type,& & psb_lsspmat_type, psb_lcspmat_type,& & psb_ldspmat_type, psb_lzspmat_type, & & psb_ls_csr_sparse_mat, psb_ld_csr_sparse_mat, & @@ -77,7 +77,7 @@ module psb_metispart_mod integer(psb_lpk_), intent(in) :: n, nparts integer(psb_lpk_), intent(in) :: ja(:), irp(:) integer(psb_lpk_), allocatable, intent(inout) :: vect(:) -#if defined(METIS_REAL_32) +#if defined(METIS_REAL_32) || !defined(HAVE_METIS) real(psb_spk_),optional, intent(in) :: weights(:) #elif defined(METIS_REAL_64) real(psb_dpk_),optional, intent(in) :: weights(:) @@ -112,19 +112,20 @@ contains end subroutine part_graph - subroutine distr_mtpart(root, ictxt) + subroutine distr_mtpart(root, ctxt) use psb_base_mod implicit none - integer(psb_ipk_) :: root, ictxt + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: root integer(psb_ipk_) :: me, np, info integer(psb_lpk_) :: n - call psb_info(ictxt,me,np) + call psb_info(ctxt,me,np) if (.not.((root>=0).and.(root1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -75,7 +75,7 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_sspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -110,7 +110,7 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) use_parts = present(parts) use_vg = present(vg) @@ -140,10 +140,10 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -156,11 +156,11 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -269,12 +269,12 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -282,8 +282,8 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -296,10 +296,10 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -319,7 +319,7 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -330,7 +330,7 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -362,7 +362,7 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -370,7 +370,7 @@ end subroutine psb_smatdist -subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& +subroutine psb_lsmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -400,7 +400,7 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -416,7 +416,7 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_lsspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -452,7 +452,7 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == root) then nrow = a_glob%get_nrows() ncol = a_glob%get_ncols() @@ -476,10 +476,10 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -492,11 +492,11 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -607,12 +607,12 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -620,8 +620,8 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -634,10 +634,10 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) il = ll call psb_spins(il,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then @@ -658,7 +658,7 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -669,7 +669,7 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -701,7 +701,7 @@ subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/util/psb_s_mat_dist_mod.f90 b/util/psb_s_mat_dist_mod.f90 index c4207da7..47f6381f 100644 --- a/util/psb_s_mat_dist_mod.f90 +++ b/util/psb_s_mat_dist_mod.f90 @@ -32,10 +32,10 @@ module psb_s_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_spk_, psb_desc_type, psb_parts, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_vect_type, & - & psb_lsspmat_type + & psb_lsspmat_type, psb_ctxt_type interface psb_matdist - subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_smatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -65,7 +65,7 @@ module psb_s_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -76,13 +76,12 @@ module psb_s_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_desc_type,& - & psb_s_base_sparse_mat, psb_s_vect_type, psb_parts + import implicit none ! parameters type(psb_sspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -93,7 +92,7 @@ module psb_s_mat_dist_mod integer(psb_ipk_), optional :: vg(:) integer(psb_ipk_), optional :: vsz(:) end subroutine psb_smatdist - subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_lsmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -123,7 +122,7 @@ module psb_s_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -134,14 +133,12 @@ module psb_s_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_desc_type,& - & psb_s_base_sparse_mat, psb_s_vect_type, psb_parts, & - & psb_lsspmat_type + import implicit none ! parameters type(psb_lsspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_sspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info diff --git a/util/psb_z_mat_dist_impl.f90 b/util/psb_z_mat_dist_impl.f90 index d45382f3..2768b21e 100644 --- a/util/psb_z_mat_dist_impl.f90 +++ b/util/psb_z_mat_dist_impl.f90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& +subroutine psb_zmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -59,7 +59,7 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -75,7 +75,7 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_zspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -110,7 +110,7 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) use_parts = present(parts) use_vg = present(vg) @@ -140,10 +140,10 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -156,11 +156,11 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -269,12 +269,12 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -282,8 +282,8 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -296,10 +296,10 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -319,7 +319,7 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -330,7 +330,7 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -362,7 +362,7 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return @@ -370,7 +370,7 @@ end subroutine psb_zmatdist -subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& +subroutine psb_lzmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -400,7 +400,7 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -416,7 +416,7 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& ! parameters type(psb_lzspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -452,7 +452,7 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& else root = psb_root_ end if - call psb_info(ictxt, iam, np) + call psb_info(ctxt, iam, np) if (iam == root) then nrow = a_glob%get_nrows() ncol = a_glob%get_ncols() @@ -476,10 +476,10 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& endif ! broadcast informations to other processors - call psb_bcast(ictxt,nrow, root) - call psb_bcast(ictxt,ncol, root) - call psb_bcast(ictxt,nnzero, root) - call psb_bcast(ictxt,nrhs, root) + call psb_bcast(ctxt,nrow, root) + call psb_bcast(ctxt,ncol, root) + call psb_bcast(ctxt,nnzero, root) + call psb_bcast(ctxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then @@ -492,11 +492,11 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& &nrow, ncol, nnzero,nrhs endif if (use_parts) then - call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + call psb_cdall(ctxt,desc_a,info,mg=nrow,parts=parts) else if (use_vg) then - call psb_cdall(ictxt,desc_a,info,vg=vg) + call psb_cdall(ctxt,desc_a,info,vg=vg) else if (use_vsz) then - call psb_cdall(ictxt,desc_a,info,nl=vsz(iam+1)) + call psb_cdall(ctxt,desc_a,info,nl=vsz(iam+1)) else info = -1 end if @@ -607,12 +607,12 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if else - call psb_snd(ictxt,nnr,iproc) - call psb_snd(ictxt,ll,iproc) - call psb_snd(ictxt,irow(1:ll),iproc) - call psb_snd(ictxt,icol(1:ll),iproc) - call psb_snd(ictxt,val(1:ll),iproc) - call psb_rcv(ictxt,ll,iproc) + call psb_snd(ctxt,nnr,iproc) + call psb_snd(ctxt,ll,iproc) + call psb_snd(ctxt,irow(1:ll),iproc) + call psb_snd(ctxt,icol(1:ll),iproc) + call psb_snd(ctxt,val(1:ll),iproc) + call psb_rcv(ctxt,ll,iproc) endif end do else if (iam /= root) then @@ -620,8 +620,8 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& do k_count = 1, np_sharing iproc = iwork(k_count) if (iproc == iam) then - call psb_rcv(ictxt,nnr,root) - call psb_rcv(ictxt,ll,root) + call psb_rcv(ctxt,nnr,root) + call psb_rcv(ctxt,ll,root) if (ll > size(irow)) then write(psb_err_unit,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) @@ -634,10 +634,10 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& end if endif - call psb_rcv(ictxt,irow(1:ll),root) - call psb_rcv(ictxt,icol(1:ll),root) - call psb_rcv(ictxt,val(1:ll),root) - call psb_snd(ictxt,ll,root) + call psb_rcv(ctxt,irow(1:ll),root) + call psb_rcv(ctxt,icol(1:ll),root) + call psb_rcv(ctxt,val(1:ll),root) + call psb_snd(ctxt,ll,root) il = ll call psb_spins(il,irow,icol,val,a,desc_a,info) if(info /= psb_success_) then @@ -658,7 +658,7 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& end if end do - call psb_barrier(ictxt) + call psb_barrier(ctxt) t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() @@ -669,7 +669,7 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& goto 9999 end if - call psb_barrier(ictxt) + call psb_barrier(ctxt) t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) t3 = psb_wtime() @@ -701,7 +701,7 @@ subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& call psb_erractionrestore(err_act) return -9999 call psb_error_handler(ictxt,err_act) +9999 call psb_error_handler(ctxt,err_act) return diff --git a/util/psb_z_mat_dist_mod.f90 b/util/psb_z_mat_dist_mod.f90 index d10200dd..2f62899e 100644 --- a/util/psb_z_mat_dist_mod.f90 +++ b/util/psb_z_mat_dist_mod.f90 @@ -32,10 +32,10 @@ module psb_z_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_dpk_, psb_desc_type, psb_parts, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_vect_type, & - & psb_lzspmat_type + & psb_lzspmat_type, psb_ctxt_type interface psb_matdist - subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_zmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -65,7 +65,7 @@ module psb_z_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -76,13 +76,12 @@ module psb_z_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_desc_type,& - & psb_z_base_sparse_mat, psb_z_vect_type, psb_parts + import implicit none ! parameters type(psb_zspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info @@ -93,7 +92,7 @@ module psb_z_mat_dist_mod integer(psb_ipk_), optional :: vg(:) integer(psb_ipk_), optional :: vsz(:) end subroutine psb_zmatdist - subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& + subroutine psb_lzmatdist(a_glob, a, ctxt, desc_a,& & info, parts, vg, vsz, inroot,fmt,mold) ! ! an utility subroutine to distribute a matrix among processors @@ -123,7 +122,7 @@ module psb_z_mat_dist_mod ! usually nv=1; if nv >1 then we have an overlap in the data ! distribution. ! - ! integer(psb_ipk_) :: ictxt + ! integer(psb_ipk_) :: ctxt ! on entry: the PSBLAS parallel environment context. ! ! type (desc_type) :: desc_a @@ -134,14 +133,12 @@ module psb_z_mat_dist_mod ! on entry: specifies processor holding a_glob. default: 0 ! on exit : unchanged. ! - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_desc_type,& - & psb_z_base_sparse_mat, psb_z_vect_type, psb_parts, & - & psb_lzspmat_type + import implicit none ! parameters type(psb_lzspmat_type) :: a_glob - integer(psb_ipk_) :: ictxt + type(psb_ctxt_type) :: ctxt type(psb_zspmat_type) :: a type(psb_desc_type) :: desc_a integer(psb_ipk_), intent(out) :: info